Советы по Delphi в Интернете
Версия от 1.4.2001
Продолжение в других файлах...
Мини-FAQ:
• A почему не работает ваш Совет... --> пришлите исправленное решение, помогите другим
• А как сделать... --> FIDO (или у Вас секретная разработка?), помогите другим
• Помогите другим, шлите свои публикации


 Что такое "Советы по Delphi"?

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

A
втором предусматривается попытка на периодичность издания, подписаться на уведомления о выходе новых версий можно здесь. При составлении "Советов" не ставилась цель включить ВСЕ материалы, отбирались лишь самые интересные. Источником "Советов" служили многочисленные западные источники (FAQ), кропотливо отобранные и переведенные на русский язык.

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

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

Ш
лите примеры, советы, полезности, статьи и давайте ссылки на свои и не свои сайты. От вас самих зависит наполняемость советов. Авторы! Дайте вторую жизнь вашим произведениям! Присылайте статьи и переводы!

Н
е удивляйтесь, если в "Советах" Вы обнаружите код для Delphi1 или даже для TurboPascal'я. Сам Паскаль практически не изменился, а идеи, реализация и технология живы до сих пор. Для описания какой-либо функции можно заглянуть в электронную справку, а для поиска идеи - в "Советы".

Предупреждение

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

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


 Индексы

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

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

[ Алгоритмы ][ Преобразования ]

  1. [000001] HEX -> Integer
  2. [000002] Преобразование десятичного числа в шестнадцатиричное
  3. [000003] Преобразование ASCII в шестнадцатиричное представление
  4. [000004] Преобразование двоичного числа в десятичное
  5. [000005] Преобразование ICO в BMP I
  6. [000909] Преобразование ICO в BMP II
  7. [000461] Перевод из BitMap в Icon
  8. [000006] Unix-строки (чтение и запись Unix-файлов)
  9. [000007] Преобразование BMP в JPEG в Delphi 3
  10. [000008] Декомпилляция звукового файла формата Wave и получение звуковых данных
  11. [000155] Преобразование '1010' в '001010'
  12. [000158] Число строкой I
  13. [000230] Число строкой II
  14. [000237] Число строкой III
  15. [000240] Число строкой IV
  16. [000243] Число строкой V
  17. [000256] Число строкой VI
  18. [000562] Число строкой VII
  19. [000580] Число строкой VIII
  20. [000857] Число строкой IX
  21. [000235] Преобразование RTF в HTML
  22. [000301] sscanf в Delphi?
  23. [000635] Преобразования типа Comp в тип Str
  24. [000703] Перекодировка текста
  25. [000705] Действительно БЫСТРОЕ преобразование сигнала в спекр и обратно (методы Хартли, Фурье и классический)
  26. [000858] Цвет строкой
  27. [000866] Преобразование в EBCDIC
  28. [000884] Преобразование String в Pchar

[ Алгоритмы ][ Даты ]

  1. [000009] Вычисление даты Пасхи
  2. [000010] Дни недели
  3. [000011] Формат даты
  4. [000012] Функция DateSer
  5. [000467] Математика времени
  6. [000556] Проверка дат
  7. [000574] Организация цикла между двумя датами
  8. [000646] Получение номера месяца по его имени
  9. [000795] Универсальная функция возврата значения элемента даты
  10. [000868] Частичный показ DateTime
  11. [000904] Внимание! TDateTime 1899

[ Алгоритмы ][ Кодирование информации ]

  1. [000074] 64-битное кодирование/декодирование I
  2. [000782] 64-битное кодирование/декодирование II
  3. [000304] Проверка кредитной карты
  4. [000675] Кодирование/декодирование строки

[ Алгоритмы ][ Математика ]

  1. [000111] FFT аглоритм для Delphi 2
  2. [000156] 32-битный CRC
  3. [000157] Возведение числа в степень I
  4. [000495] Возведение числа в степень II
  5. [000159] Вычислитель математических формул
  6. [000849] Разбиение шестнадцатиричной величины
  7. [000897] Функция представления чисел с плавающей точкой и нужным числом разрядов

[ Алгоритмы ][ Разное ]

  1. [000013] Ханойская башня
  2. [000014] Аглоритм (уравнение) для определения восхода/захода солнца и луны
  3. [000160] Выставление и сброс битов
  4. [000161] Как вычислить расстояние, имея широту и долготу.
  5. [000406] Функция бинарного поиска
  6. [000624] Управление битами

[ Win API ][ Переменные среды ]

  1. [000016] Получение переменных окружения DOS I
  2. [000710] Получение переменных окружения DOS II
  3. [000017] Изменение системного времени из Delphi

[ Win API ][ Завершение работы Windows ]

  1. [000018] События, происходящие в приложениях Delphi при завершении работы Windows
  2. [000019] Завершение работы Windows
  3. [000611] Выключение питания ATX коpпуса из-под DOS

[ Win API ][ Режим энергосбережения (Power saving) ]

  1. [000020] Управление монитором

[ Win API ][ Разное ]

  1. [000021] Извлечение из EXE-файла иконки и рисование ее в TImage I
  2. [000389] Извлечение из EXE-файла иконки и рисование ее в TImage II
  3. [000022] Как не допустить запуск второй копии программы I
  4. [000423] Как не допустить запуск второй копии программы II
  5. [000489] Как не допустить запуск второй копии программы III
  6. [000750] Как не допустить запуск второй копии программы IV
  7. [000780] Как не допустить запуск второй копии программы V
  8. [000883] Как не допустить запуск второй копии программы VI
  9. [000899] Как не допустить запуск второй копии программы VII
  10. [000023] Получение имени модуля
  11. [000024] Каким образом, программным путем, можно узнать о завершении запущенной программы?
  12. [000294] Как запустить другую программу?
  13. [000295] Как с помощью функции Textout вывести на канве прозрачный текст
  14. [000310] Ассоциативное выполнение
  15. [000352] Запуск программы с ожиданием
  16. [000358] Вращение текста
  17. [000364] Оболочка ShellExecute
  18. [000385] Количество запущенных копий программы
  19. [000392] Изменение иконки приложения
  20. [000458] Определение окончания работы другого приложения
  21. [000479] Извлечение иконки из EXE/DLL-файла
  22. [000518] Поиск окна с помощью функции FindWindow
  23. [000526] Пример EnumWindows
  24. [000530] Управление игрой FreeCell
  25. [000568] Извещение об изменениях WIN.INI
  26. [000618] Активизация предыдущего экземпляра вашей программы
  27. [000622] Завершение всех работающих приложений
  28. [000804] Обработка WM_SysCommand
  29. [000863] Улучшение работы LockWindowUpdate
  30. [000881] FlashWindow для иконок
  31. [000919] WinExecAndWait32
  32. [000920] WinExecAndWait
  33. [000933] Проблема синтаксиса DrawCaption

[ Паскаль ][ Массивы ]

  1. [000025] Массив в Delphi
  2. [000026] Динамические массивы I
  3. [000362] Динамические массивы II
  4. [000759] Динамические массивы III
  5. [000943] Динамические массивы IV
  6. [000300] Заполнения массива случаными неповторяющимися значениями
  7. [000544] Пример массива констант (Array of Const) I
  8. [000937] Пример массива констант (Array of Const) II
  9. [000549] Работа с большими массивами
  10. [000724] Использование многомерного массива
  11. [000729] Массив без ограничения типа и размера
  12. [000764] Создание многомерного массива
  13. [000787] Запись массива на диск
  14. [000828] Сохранение массива c изображениями
  15. [000955] Массив констант во время выполнения приложения
  16. [000990] Шаблон массива переменной длины

[ Паскаль ][ Вычисления ]

  1. [000335] Эмулятор плавающей точки

[ Паскаль ][ Память ]

  1. [000147] Предел сегмента данных в 64K
  2. [000269] ???? Слишком большой сегмент данных ???? I
  3. [000832] ???? Слишком большой сегмент данных ???? II
  4. [000361] Динамическое распределение памяти I
  5. [000936] Динамическое распределение памяти II
  6. [000491] StrAlloc и GetMem
  7. [000860] Быстрое сравнение памяти
  8. [000944] Управление размером сегмента данных

[ Паскаль ][ Методы ]

  1. [000297] Перекрытие виртуальных методов
  2. [000307] Вызов процедуры, имя которой содержится в переменной I
  3. [000697] Вызов процедуры, имя которой содержится в переменной II
  4. [000339] Динамические и виртуальные методы
  5. [000452] Использование SetBounds
  6. [000643] Override/Vitual/Dynamic - методы
  7. [000691] Макро-процедуры
  8. [000811] Выполнение процедуры по адресу

[ Паскаль ][ Объекты ]

  1. [000312] Создание объектных переменных
  2. [000483] Создание объектов любого типа
  3. [000506] Информация о TClass
  4. [000696] Переназначения объектов

[ Паскаль ][ Параметры ]

  1. [000313] Пример переменного количества параметров
  2. [000488] Переменное количество параметров любого типа
  3. [000992] Конфликт имен параметров

[ Паскаль ][ Указатели ]

  1. [000308] Как избежать использования неактуальных указателей
  2. [000405] Получение ссылки на экземпляр класса
  3. [000430] Работа метода Assign
  4. [000627] Арифметика указателей

[ Паскаль ][ Свойства ]

  1. [000474] Код определения свойств
  2. [000525] Регистрация редактора свойства
  3. [000543] Демонстрация DefineProperties
  4. [000545] Свойство только для чтения во время выполнения программы
  5. [000602] Использование перечислимых констант
  6. [000658] Поиск свойств
  7. [000662] Создание редактора свойства
  8. [000753] Показ свойств во время выполнения программы
  9. [000927] Свойство TStringList

[ Паскаль ][ Потоки ]

  1. [000613] Реализация собственного потока

[ Паскаль ][ Строки ]

  1. [000249] Эквивалент Trim$(),Mid$() и др.
  2. [000250] Фильтрованный поиск в строке
  3. [000251] Разбивка строки на слова
  4. [000252] Замена подстрок
  5. [000253] Как сделать, чтобы первая буква каждого слова в строке была в верхнем регистре?
  6. [000254] Как определить, что два слова имеют схожее произношение?
  7. [000257] Удаление ненужных подстрок из строки
  8. [000258] Синтаксический анализ строки
  9. [000260] Несколько полезных функций для работы со строками
  10. [000447] Функция наполнения строки
  11. [000758] Паскалевский эквивалент StrTok
  12. [000760] Строка как объект StringList
  13. [000761] Строковая нумерация
  14. [000812] String и PChar

[ Паскаль ][ Типы ]

  1. [000154] Огромные числа
  2. [000162] Некорректные вещественные значения
  3. [000677] Типы данных 16 & 32 бит
  4. [000829] Округление реальных типов
  5. [000867] Integer как SmallInt
  6. [000880] Величина SizeOf?

[ Паскаль ][ Модули ]

  1. [000321] Не работает функция Writeln
  2. [000324] Определение графики в WinTypes/Graphics
  3. [000820] Текущий модуль и проект

[ Паскаль ][ Разное ]

  1. [000794] Пример использования ActiveControl
  2. [000810] Прерывание цикла FOR
  3. [000856] Новые возможности языка в Delphi 2
  4. [000991] Поиск класса
  5. [000995] Редактор свойства Color с заданными ограничениями

[ Базы данных ][ Clipper ]

  1. [000975] Работа с индексами Clipper'а

[ Базы данных ][ Создание ]

  1. [000027] Создание db-файла во время работы приложения
  2. [000343] Формат файла ASCII-схемы
  3. [000416] Динамическое создание полей I
  4. [000702] Динамическое создание полей II
  5. [000463] Создание таблицы с автоинкрементальным полем
  6. [000484] Создание кросс-таблицы
  7. [000532] Создание/удаление полей во время выполнения программы
  8. [000766] Кросс-таблица через pivot-таблицу
  9. [000792] Создание уникального табличного индекса

[ Базы данных ][ Доступ ]

  1. [000028] Очень медленный доступ к таблице при первом обращении
  2. [000418] Доступ к файлам Paradox через BDE в сети Lantastic Network
  3. [000419] Импорт CSV ASCII
  4. [000420] Имя пользователя Paradox
  5. [000538] Загрузка изображений в Blob-поля
  6. [000551] ASCII-файл с использованием полей
  7. [000565] Blob-поля, потоки, компрессия...
  8. [000593] Изображения и InterBase Blob-поля
  9. [000641] ASCII драйвер для CSV-файлов
  10. [000693] Извлечение текста из TMemoField
  11. [000737] Общий доступ к данным с DBD & Pdox
  12. [000939] Получение Memo с помощью Query
  13. [000940] Извлечение изображения из BLOB-поля
  14. [000942] Данные индекса таблицы
  15. [000978] Запись/чтение чисел в Blob-поле

[ Базы данных ][ Поиск ]

  1. [000029] Поиск величины при вводе I
  2. [000383] Поиск величины при вводе II
  3. [000030] Быстрый поиск в базах данных
  4. [000226] Поиск записи в больших таблицах

[ Базы данных ][ Калькуляция ]

  1. [000031] Хитрость OnCalcFields
  2. [000451] Вычисление суммы полей
  3. [000542] Функция вычисления суммы полей

[ Базы данных ][ dBASE ]

  1. [000063] Таблицы dBASE: Структура .DBF-файла
  2. [000372] Пакование таблиц dBASE
  3. [000531] Обработка исключения `index not found`
  4. [000561] DBase и 'особые случаи' BDE
  5. [000563] DBFSeek и DBFLocate
  6. [000630] dBASE - Индексы выражений
  7. [000738] Текущий RecNo (dBase/Pdox)
  8. [000815] Восстановление записи dBase
  9. [000830] Формат и размер dBase-поля

[ Базы данных ][ Paradox ]

  1. [000340] Форматированные Memo-поля таблиц Paradox
  2. [000349] Создание autoincrement поля
  3. [000379] Вызов TUTILITY
  4. [000440] Пароли Paradox
  5. [000455] Печать структуры таблицы Paradox
  6. [000631] Каскадированное удаление с проверкой целостности Paradox
  7. [000706] Ограничения Paradox
  8. [000712] Медленное открытие таблицы Paradox?
  9. [000733] Чтение OLE из Blob поля Paradox
  10. [000739] Пакование таблиц Paradox и dBASE
  11. [000767] Дубликат Paradox/dBase записи
  12. [000771] Изменение месторасположения *.NET-файла во время работы
  13. [000798] Paradox в сети
  14. [000905] Вскрытие запароленной таблицы Paradox
  15. [000931] Размеры полей таблицы Paradox
  16. [000980] Paradox и неверные индексы Win95

[ Базы данных ][ Access ]

  1. [000376] Использование таблиц Access I
  2. [000514] Использование таблиц Access II

[ Базы данных ][ Разное ]

  1. [000032] Сканирование версии структуры базы данных
  2. [000033] Перемещение таблиц
  3. [000034] Прокрутка таблицы: хитрость PeekMessage()
  4. [000382] Запись nnn из nnn
  5. [000402] Копирование массива целочисленных чисел в Blob-поле
  6. [000465] Копирование StringList в Memo-поле и обратно
  7. [000487] Копирование записи из одной таблицы в другую
  8. [000533] Полный слепок полей таблицы
  9. [000564] Правила для SetRange
  10. [000566] ActiveControl имеет DataSet?
  11. [000599] Копирование записи в пределах одной и той же таблицы
  12. [000600] Определение типа базы данных
  13. [000789] Простой пример работы с базой данных из DLL
  14. [000793] Стандартный запрос на удаление записи в таблице
  15. [000809] Сортировка связанного списка
  16. [000844] Работа с автоинкрементальными (AutoInc) полями
  17. [000873] Фильтр посредством логического поля
  18. [000875] Причуда AddIndex
  19. [000973] Использование нумерации в TFields

[ BDE ][ Псевдонимы ]

  1. [000035] Задание псевдонима программным путем
  2. [000036] Информация о псевдонимах BDE
  3. [000640] Отображение всех псевдонимов в ComboBox
  4. [000707] Изменение псевдонима во время выполнения программы
  5. [000714] Синтаксис функции DbiAddAlias
  6. [000765] Добавление псевдонима с помощью функции DbiAddAlias
  7. [000871] Имитация псевдонима PdoxWIN 'PRIV'

[ BDE ][ Ошибки ]

  1. [000567] Перехват ошибок DBEngine
  2. [000592] Обработка исключений EDBEngineError

[ BDE ][ InterBase ]

  1. [000517] Автоматический logon к локальной InterBase
  2. [000559] Автоинкрементальные поля и Interbase I
  3. [000713] Автоинкрементальные поля и Interbase II
  4. [000872] Автоинкрементальные поля и Interbase III
  5. [000639] Interbase BLOB-поля
  6. [000731] OLE <--> Interbase
  7. [000962] Автоматический запуск сервера Interbase

[ BDE ][ ODBC ]

  1. [000522] Конфигурирование ODBC
  2. [000614] Конфигурирование ODBC и псевдонима
  3. [000637] ODBC соединения
  4. [000638] Установка ODBC/Watcom SQL
  5. [000656] BDE/ODBC/SQL Server 6.0
  6. [000698] Вопросы Delphi/BDE/SQL Links
  7. [000708] Ошибка ODBC SQL Prepare
  8. [000853] Получение дескриптора ODBC соединения

[ BDE ][ Oracle ]

  1. [000775] Связь с personal Oracle
  2. [000930] Связь BDE/Oracle

[ BDE ][ Записи ]

  1. [000369] Текущий номер записи
  2. [000870] Вставка новой записи через буфер

[ BDE ][ SQL ]

  1. [000325] Имя SQL-таблицы
  2. [000377] Интерактивные SQL-запросы
  3. [000391] Синтах SQL-функции Substring
  4. [000412] SQL и расширенные символы
  5. [000502] SQL в Delphi
  6. [000528] SQL outer join
  7. [000732] Local SQL и временная таблица
  8. [000734] Проблемы StograyProc у SQL server
  9. [000841] SQL: вложенные пробелы
  10. [000843] Параметризованные запросы
  11. [000982] Не работающий SQL OR

[ BDE ][ Разное ]

  1. [000615] Копирование таблицы с помощью DBE
  2. [000623] Проверка наличия IDAPI
  3. [000632] Распространение BDE
  4. [000655] Использование BDE в сети
  5. [000711] Пример DbiAddFilter
  6. [000772] Огромные LCK-файлы
  7. [000791] Ограничения IDAPI
  8. [000928] Локальный общий доступ
  9. [000958] Конфликт IDAPI German/English
  10. [000981] BDE32 приложения в ptp-сети
  11. [000983] Изменение данных в Delphi 2 (BDE)
  12. [000984] RecCount в таблицах ASCII
  13. [000985] Демонстрация обратного вызова BDE

[ Мультимедиа ][ Аудио-компакт ]

  1. [000037] Получение идентификатора диска

[ Мультимедиа ][ Звук ]

  1. [000242] Низкоуровневые процедуры обработки звука
  2. [000245] Извлечение звуков из системного динамика под Windows 95 I
  3. [000757] Извлечение звуков из системного динамика под Windows 95 II
  4. [000246] Формат Wave-файла
  5. [000825] Создание пустого wav-файла

[ Аппаратное обеспечение ][ Джойстик ]

  1. [000184] Контроль джойстика в Delphi

[ Аппаратное обеспечение ][ CD-ROM ]

  1. [000038] Открытие и закрытие привода CD-ROM

[ Аппаратное обеспечение ][ CPU ]

  1. [000381] CPU Speed routine
  2. [000083] Работа с портами микропроцессора
  3. [000778] Получение информации о процессоре

[ Аппаратное обеспечение ][ Принтер ]

  1. [000095] Форматы бумаги
  2. [000205] Управляющие коды принтера
  3. [000206] Настройки принтера
  4. [000207] Печать повернутого текста
  5. [000208] Растягивание изображения при печати
  6. [000209] Как напечатать изображение?
  7. [000210] Сброс на печать текстового файла
  8. [000211] Построчная печать
  9. [000212] Хитрости печати
  10. [000213] Escape код PASSTHROUGH
  11. [000214] Сохранение точных размеров при печати
  12. [000215] Размер полей при печати
  13. [000216] Изменение свойств печати во время ее выполнения
  14. [000380] Печать ячеек
  15. [000398] Метрики принтера
  16. [000408] Диалог прекращения печати
  17. [000459] Прерывание работы принтера
  18. [000529] Печать всей формы
  19. [000539] Печать содержимого TMemo/TListbox
  20. [000610] Печать текста в обход Windows
  21. [000716] Печать на любом принтере
  22. [000822] Пример использования TPrinter

[ Аппаратное обеспечение ][ Дисковод ]

  1. [000076] Как мне проверить готовность диска 'a:'? I
  2. [000527] Как мне проверить готовность диска 'a:'? II

[ Аппаратное обеспечение ][ Винчестер ]

  1. [000125] Серийный номер тома
  2. [000628] Управление метками томов дисков

[ Аппаратное обеспечение ][ Клавиатура ]

  1. [000137] Звуковой сигнал при нажатии <ENTER>
  2. [000138] Недоступность комбинаций alt-tab и ctrl+esc I
  3. [000901] Недоступность комбинаций alt-tab и ctrl+esc II
  4. [000139] Как мне определить нажатие клавиш со стрелками?
  5. [000140] Перехват (Hook) клавиатуры (программа Sendkeys)
  6. [000503] Перехват (Hook) клавиатуры (программа Sendkeys) - Полная версия
  7. [000141] Имитация нажатия клавиши
  8. [000142] Как? Клавиша ENTER вместо клавиши TAB I
  9. [000427] Как? Клавиша ENTER вместо клавиши TAB II
  10. [000144] Caps Lock (и другие подобные клавиши)
  11. [000146] Недоступность Ctrl-Alt-Del I
  12. [000774] Недоступность Ctrl-Alt-Del II
  13. [000255] Коды виртуальных клавиш
  14. [000287] Посылка кода клавиши/Текста в окно...
  15. [000348] Хитрость KeyPreview
  16. [000404] Индикация статуса клавиш I
  17. [000617] Индикация статуса клавиш II
  18. [000434] Прерывание клавиши ENTER
  19. [000442] Использование клавиш для управления компонентами
  20. [000476] Перехват курсорных клавиш I
  21. [000669] Перехват курсорных клавиш II
  22. [000560] Чтение и установка клавиши NumLock
  23. [000634] Имитация Tab
  24. [000796] Обработка нажатий клавиш `вверх-вниз`
  25. [000819] Как программно нажать клавишу
  26. [000938] Создание собственных горячих клавиш
  27. [000956] Прерывание клавиши Tab

[ Аппаратное обеспечение ][ Модем ]

  1. [000179] AT-команды модема
  2. [000180] S-регистры модема

[ Аппаратное обеспечение ][ Порты ]

  1. [000238] Работа с последовательными портами I
  2. [000448] Работа с последовательными портами II
  3. [000239] Работа с портами под Win95, обзор и теория
  4. [000241] Доступ к аппаратным портам из DELPHI 2
  5. [000597] Чтение/Запись в IO-порт

[ Аппаратное обеспечение ][ Мышь ]

  1. [000181] Добавление события OnMouseLeave
  2. [000182] Использование анимированных курсоров
  3. [000183] Создание мышиного перехватчика
  4. [000185] Подсветка компонента во время перемещения над ним мыши
  5. [000186] Покидание мыши области компонента
  6. [000473] Определение и использование курсора
  7. [000588] Управление MouseOver через Hint

[ Операционная система ][ Буфер обмена ]

  1. [000039] Просмотр буфера обмена I
  2. [000523] Просмотр буфера обмена II
  3. [000040] Копирование в буфер обмена
  4. [000041] Форма как графический объект
  5. [000302] Поддержка Cut Copy Paste I
  6. [000851] Поддержка Cut Copy Paste II
  7. [000595] Cut/Copy/Paste через WinAPI
  8. [000799] Копирование большого файла в буфер обмена
  9. [000801] функции меню Вырезать/Копировать/Вставить
  10. [000852] Помещение изображения в буфер обмена
  11. [000966] Встроенные форматы буфера обмена

[ Операционная система ][ Панель управления ]

  1. [000290] Панель Управления

[ Операционная система ][ Корзина (Recycle Bin) ]

  1. [000077] Как удалить файлы в корзину (Recycle Bin)?

[ Операционная система ][ Файловая система ]

  1. [000079] Процедура форматирования
  2. [000081] Как мне подсчитать занимаемое директорией место?
  3. [000085] Как прочесть атрибут файла "Last Accessed" (последний доступ)?
  4. [000086] Как мне преобразовать "Long File Name.pas" в "longfi~1.pas"?
  5. [000087] Проблема получения времени создания файла
  6. [000088] Копирование файлов I
  7. [000621] Копирование файлов II
  8. [000126] Поиск на винчестере
  9. [000222] Инсталляционная директория Win95
  10. [000268] Управление каталогами и файлами
  11. [000280] Путь/Имя папки 'My Computer'
  12. [000285] Поиск загрузочного диска
  13. [000305] Поиск текста в текстовом файле
  14. [000351] Быстрое копирование файла
  15. [000367] Блокировка файла
  16. [000373] LZCopy
  17. [000384] Файловые переменные
  18. [000519] Доступ к нетипизированному файлу
  19. [000534] Управление атрибутом файла date/time
  20. [000603] Установка режима бинарного файла
  21. [000723] Как мне открыть файл общего доступа?
  22. [000744] Удаление непустого каталога
  23. [000755] BlockRead и текстовый файл
  24. [000838] Readln для более чем 255 символов
  25. [000865] Быстрая обработка файла
  26. [000998] Изменение расширения BITMAP???

[ Операционная система ][ Сообщения ]

  1. [000288] Сообщения Windows - введение
  2. [000605] Рисование на минимизированной иконке
  3. [000625] Сохранение приложения в виде иконки

[ Операционная система ][ Регистры ]

  1. [000220] Регистры - доступ и использование вместо WIN.INI
  2. [000223] Как мне получить из регистров информацию о временной зоне (DST)?
  3. [000225] Объекты и Tregistry
  4. [000291] Ассоциирование типов файлов (расширений)

[ Операционная система ][ Ярлыки (Shortcuts) ]

  1. [000080] Как создавать ярлыки (shortcuts)?
  2. [000270] Чтение флажка "Run Minimized"

[ Операционная система ][ Перетащи и брось (Drag and Drop) ]

  1. [000089] Drag & Drop c Win95 Explorer I
  2. [000117] Drag & Drop c Win95 Explorer II
  3. [000344] ListBox и Drag&Drop
  4. [000355] Преобразование координат
  5. [000413] Прием файлов из Program Manager I
  6. [000466] Прием файлов из Program Manager II
  7. [000436] Перетаскивание элементов управления c рамкой контура
  8. [000445] Drag & Drop между двумя компонентами ListBox
  9. [000651] Drag & Drop TImage
  10. [000754] Drag&Drop с минимизированным приложением

[ Операционная система ][ Шрифты ]

  1. [000090] Как приложению воспользоваться своими шрифтами? Без помощи пользователя
  2. [000091] Включение шрифта как ресурса в *.EXE
  3. [000281] Как определить, большие или маленькие шрифты используются в системе?
  4. [000282] Большие/Маленькие шрифты?
  5. [000320] Переключение с 96DPI на 120DPI
  6. [000322] Размер масштабированного шрифта
  7. [000728] Проверка шрифта с фиксированной шириной
  8. [000850] Свойства шрифта Style/Color в виде строки
  9. [000965] PopupComponent и шрифты

[ Операционная система ][ Диалоги ]

  1. [000104] Центрирование информационного диалога (MessageDlg)
  2. [000113] Вызов стандартного системного окна "О программе"
  3. [000573] MessageDlg в обработчике OnExit
  4. [000741] MessageDlg без Gliph
  5. [000768] Избавление от системного окна с ошибкой
  6. [000976] Размер диалогового окна

[ Операционная система ][ Рабочий стол ]

  1. [000119] Снимок DESKTOP в form.canvas
  2. [000121] Как получить снимок экрана (типа screen-capture программ)?
  3. [000273] Shell_NotifyIcon
  4. [000276] Как спрятать панель задач в Windows 95?
  5. [000279] Как программно заменить обои на рабочем столе? I
  6. [000453] Как программно заменить обои на рабочем столе? II
  7. [000284] Определение имени Группы Запуска (StartUp)
  8. [000289] Кнопки в панели задач Win95
  9. [000292] Скрытие кнопки "Пуск"
  10. [000877] Количество цветов в системе
  11. [000988] Delphi 1 и Панель Задач Windows 95

[ Операционная система ][ Сеть ]

  1. [000200] Обзор сети (типа Network Neighborhood - Сетевое Окружение)
  2. [000201] Получение сетевого имени пользователя
  3. [000202] Подключение сетевого диска в Delphi
  4. [000203] Вызов диалога подключения сетевого диска
  5. [000204] Определение своего IP адреса
  6. [000776] Ошибка отключения сетевого диска

[ Операционная система ][ Хранитель экрана ]

  1. [000236] Создание хранителя экрана (Screen Saver)

[ Операционная система ][ Потоки ]

  1. [000261] Рассуждения о потоках

[ Операционная система ][ Разное ]

  1. [000078] Сокращенное имя каталога
  2. [000107] Как запустить приложение в полноэкранном режиме?
  3. [000114] Показ иконки зарегистрированного расширения
  4. [000115] Автоматический выбор произвольный пункт PopupMenu
  5. [000224] Сохранение параметров шрифта в INI-файле
  6. [000278] Определение версии Windows
  7. [000394] Запуск калькулятора Windows
  8. [000472] Определение версии DOS и Windows
  9. [000661] Изменение шрифта у текста всплывающей подсказки
  10. [000743] Всплывающие подсказки у выключенных кнопок
  11. [000805] Как использовать Список Задач (Tasklist)
  12. [000890] Занесение сообшения в EventLog (Windows NT)
  13. [000960] Win95 или WinNT для Delphi 1.0

[ Компоненты ][ BitBtn ]

  1. [000042] Смена иконки BitBtn во время работы приложения
  2. [000390] Мутация кнопок
  3. [000636] Кнопка с несколькими строчками текста I
  4. [000722] Кнопка с несколькими строчками текста II
  5. [000969] Альтернатива кнопкам в Delphi

[ Компоненты ][ Button ]

  1. [000996] Нажатие кнопки

[ Компоненты ][ ComboBox ]

  1. [000511] Программное открытие ComboBox

[ Компоненты ][ DBComboBox ]

  1. [000846] Заполнение TDBComboBox/ListBox
  2. [000911] Ошибка в TDBComboBox или особенность работы?

[ Компоненты ][ DBCtrlGrid ]

  1. [000296] Различные цвета строк в DBCtrlGrid

[ Компоненты ][ DBEdit ]

  1. [000417] Перевод в верхний регистр первого вводимого символа
  2. [000439] Преобразование TEdit в TDBEdit

[ Компоненты ][ DBGrid ]

  1. [000064] Использование опции MultiSelect в DBGRID
  2. [000065] Помещение компонентов в DBGRID
  3. [000066] Сортировка колонок в DBGRID
  4. [000067] DBGRID с цветными ячейками I
  5. [000403] DBGRID с цветными ячейками II
  6. [000968] DBGRID с цветными ячейками III
  7. [000068] Показ изображений в DBGrid
  8. [000069] Модуль Db_QBF.PAS, позволяющий в Delphi осуществить форму запроса для компонентов DbGrid
  9. [000070] Сохранение и восстановление конфигурации DBGRID
  10. [000071] Изменение размеров DBGrid
  11. [000072] Перемещение из DbGrid
  12. [000329] DbGrid и клавиши акселерации
  13. [000330] TDBGrid - свойства FixRows & FixCols
  14. [000331] TDBGrid - поддержка одинарного щелчка
  15. [000334] Эксперт создания таблиц
  16. [000371] Работа с графическими полями
  17. [000378] Предохранение от автодобавления записи
  18. [000411] Перехват события компонента DBGrid MouseDown
  19. [000411] Использование Enter как Tab в TDBGrid
  20. [000569] DBGrid c FixedCols
  21. [000571] Обновление вычисляемых полей в DBGrid
  22. [000591] Рисование текста в DBGrid I
  23. [000673] Рисование текста в DBGrid II
  24. [000608] Симуляция нажатия кнопки при наличии DBGrid
  25. [000629] DBGrid без вертикальной полосы прокрутки
  26. [000668] Многострочный DBGrid
  27. [000676] DBGrid DefaultDrawDataCell
  28. [000740] TDBGrid CutToClipboard
  29. [000813] TDBGrid с номером строки и пр.
  30. [000887] Копирование информации из DBGrid-а в Clipboard
  31. [000906] Буфер обмена и ячейки DBGrid-а
  32. [000957] Текстовое содержимое ячейки DBGrid
  33. [000970] Dbgrid - выбранные строки

[ Компоненты ][ DBImage ]

  1. [000869] Проблема хранения TDBImage

[ Компоненты ][ DBLookupComboBox ]

  1. [000971] Показываемое DBLookupComboBox значение

[ Компоненты ][ DBMemo ]

  1. [000374] Копирование текста DBMemo
  2. [000900] TDBMemo в TDBCtrlGrid?

[ Компоненты ][ DBNavigator ]

  1. [000145] Пример KeyDown компонента DBNavigator
  2. [000499] Вызов кнопок DBNavigator
  3. [000553] Свойства кнопок DBNavigator
  4. [000752] DBNavigator без иконок

[ Компоненты ][ DBRadioGroup ]

  1. [000333] Событие OnChange компонента DBRadioGroup

[ Компоненты ][ DrawGrid ]

  1. [000512] Пример TDrawGrid Drawcell

[ Компоненты ][ Edit ]

  1. [000015] Автоматический формат даты в компоненте Edit
  2. [000043] Массив Edit-компонентов
  3. [000421] Расположение текста в правой части TEdit
  4. [000501] Ограничение TEdit на ввод не-цифровой информации
  5. [000515] Хитрый TEdit
  6. [000550] Числовая маска компонента Edit c помощью OnKeyPress I
  7. [000903] Числовая маска компонента Edit c помощью OnKeyPress II
  8. [000619] Edit: SetFocus в OnExit
  9. [000945] Проверка на соответствие содержимого TEdit
  10. [000994] Матрица на основе TEdit

[ Компоненты ][ FileListBox ]

  1. [000653] FileListBox с двумя колонками

[ Компоненты ][ Header ]

  1. [000399] THeader как сплиттер

[ Компоненты ][ Image ]

  1. [000318] Изображение не масштабируется
  2. [000326] Вопросы палитры
  3. [000386] Изменение палитры при выводе изображения
  4. [000407] Хитрость вывода изображения
  5. [000672] Рисование прямоугольника на изображении

[ Компоненты ][ Label ]

  1. [000044] 3D-рамка для текстовых компонентов
  2. [000481] Комбинация TLabel и TEdit
  3. [000779] TLabel+TEdit без контейнера

[ Компоненты ][ ListView ]

  1. [000946] TListView, TTreeView

[ Компоненты ][ ListBox ]

  1. [000148] Изменение шрифта в Listbox
  2. [000149] Колонки в TListBox
  3. [000150] Изменение позиций элементов ListBox с помощью drag&drop I
  4. [000575] Изменение позиций элементов ListBox с помощью drag&drop II
  5. [000649] Изменение позиций элементов ListBox с помощью drag&drop III
  6. [000756] Изменение позиций элементов ListBox с помощью drag&drop IV
  7. [000151] Компонент Check List
  8. [000152] TabStop в Listbox
  9. [000153] Как сделать так, чтобы каждая строка в ListBox имела свой цвет?
  10. [000422] Инкрементальный поиск в ListBox
  11. [000541] Расширение компонента ListBox
  12. [000548] Уменьшение мерцания ListBox в обработчике OwnerDraw
  13. [000607] Пример Ownerdraw для Listbox
  14. [000685] Обнаружение прокрутки TListBox
  15. [000686] Щелчок в пустой области TListBox
  16. [000692] Использование выбранных элементов TListBox
  17. [000950] Расширение TListBox

[ Компоненты ][ MainMenu ]

  1. [000173] Перехват клавиши SHIFT во время выбора пункта меню
  2. [000175] Добавление иконки в меню
  3. [000176] Динамическое добавление пунктов меню I
  4. [000769] Динамическое добавление пунктов меню II
  5. [000177] Очень длинные меню
  6. [000178] Пункт меню "Помощь" в правой части окна
  7. [000346] Слияние MDI-меню
  8. [000540] Назначение обработчика MenuItem OnClick
  9. [000999] Озорные меню

[ Компоненты ][ MediaPlayer ]

  1. [000509] Запись с помощью MediaPlayer

[ Компоненты ][ Memo ]

  1. [000171] ?? Прокрутка Memo ??
  2. [000172] Событие "Key press" и курсорные клавиши (стрелки) в Tmemo
  3. [000363] Поиск и замена текста в Tmemo
  4. [000393] Текущая позиция Tmemo I
  5. [000482] Текущая позиция Tmemo II
  6. [000432] Сохранение Tmemo в EXE
  7. [000457] Memo в StringList и обратно
  8. [000477] Эквивалент вкл/выкл эха в Memo
  9. [000480] Использование встроенного отката в Memo
  10. [000554] TMemo с row & col
  11. [000642] Ограничение размера Memo
  12. [000683] Memo со своими шрифтами и др.
  13. [000802] Добавление строк в Memo
  14. [000803] Обнаружение прокрутки TMemo
  15. [000924] Вставка текста в TMemo
  16. [000954] Управление прокруткой Memo
  17. [001000] Импортирование файла в компонент Memo

[ Компоненты ][ NoteBook ]

  1. [000400] События OnClick/Onchange компонента Notebook
  2. [000454] Создание страниц компонента Notebook во время работы приложения
  3. [000520] Итерация элементов управления компонента Notebook
  4. [000616] Проблема с освобождением ресурсов Notebook
  5. [000664] Notebook как контейнер для форм I
  6. [000823] Notebook как контейнер для форм II
  7. [000800] Notebook - добавление и удаление страниц
  8. [000952] Включение/Выключение закладки Notebook

[ Компоненты ][ OutLine ]

  1. [000475] Производная TOutline
  2. [000594] TOutLine drag & drop
  3. [000721] TOutline OwnerDraw - значение индекса
  4. [000783] Пример отрисовки TOutline
  5. [000949] Поточность TOutline

[ Компоненты ][ PaintBox ]

  1. [000824] TPaintBox в буфер обмена

[ Компоненты ][ Panel ]

  1. [000116] Перемещение мышью панели на форме во время выполнения программы
  2. [000315] Панель с изменяющимися размерами
  3. [000947] Компонент со вложенной панелью

[ Компоненты ][ PopupMenu ]

  1. [000174] Как динамически создавать пункты подменю в PopupMenu
  2. [000136] Динамическое создание пункта меню в PopupMenu
  3. [000725] Как вызвать PopupMenu?
  4. [000730] Обработчик динамически созданного пункта меню
  5. [000839] Использование контекстного меню с VBX
  6. [000953] Вызов контекстного меню в позиции курсора

[ Компоненты ][ ProgressBar ]

  1. [000490] ProgressBar в StatusBar?

[ Компоненты ][ Query ]

  1. [000247] Поиск записи с помощью TQuery I
  2. [000589] Поиск записи с помощью TQuery II
  3. [000496] Ограничения C/S TQuery

[ Компоненты ][ RichEdit ]

  1. [000231] Чтение текста RichEdit из базы данных
  2. [000232] Подсчет слов в Richedit
  3. [000233] Ошибка RichEdit в Delphi 2.01 под NT 4
  4. [000234] Проблема печати RTF
  5. [000388] Исправление загрузки RTF текста через поток
  6. [000932] Предел на размер текста в RichEdit

[ Компоненты ][ ScrollBox ]

  1. [000045] Синхронизация двух компонентов Scrollbox

[ Компоненты ][ SpeedButton ]

  1. [000558] Двойной щелчок на TSpeedButton

[ Компоненты ][ Splitter ]

  1. [000046] Конструирование Splitter

[ Компоненты ][ StatusBar ]

  1. [000047] Обработчик события OwnerDraw в компоненте StatusBar
  2. [000306] Показ всплывающих подсказок в строке состояния I
  3. [000498] Показ всплывающих подсказок в строке состояния II

[ Компоненты ][ StringGrid ]

  1. [000048] Установка атрибутов -=Только для чтения=- у столбцов компонента StringGrid
  2. [000049] Помещение изображения в ячейку StringGrid
  3. [000050] Сохранение и чтение Tstringgrid
  4. [000314] Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid
  5. [000468] TStringGrid и файловый поток
  6. [000647] Выравнивание колонок StringGrid I
  7. [000678] Выравнивание колонок StringGrid II
  8. [000657] Фокус ячейки TStringGrid
  9. [000659] TStringgrid с фокусом (OnDrawCell)
  10. [000718] Помещение компонентов в StringGrid
  11. [000818] Выбор строки/колонки компонента TStringGrid
  12. [000821] Ширина колонок TStringGrid
  13. [000833] Цвет неактивной ячейки StringGrid
  14. [000848] Вставка и удаление строк в StringGrid

[ Компоненты ][ TabbedNotebook ]

  1. [000051] Добавление элементов управления в TTabbedNotebook и TNotebook
  2. [000052] Недоступная закладка в компоненте Tabbednotebook
  3. [000328] Исходный код Tabbednotebook
  4. [000426] Динамические создание объектов в Tabbednotebook I
  5. [000687] Динамические создание объектов в Tabbednotebook II

[ Компоненты ][ Table ]

  1. [000053] Создание компонента TTable без формы I
  2. [000359] Создание компонента TTable без формы II
  3. [000375] Создание компонента TTable без формы III
  4. [000365] Замена KeyFind
  5. [000366] Синхронизация таблицы и StringList
  6. [000368] Функция Locate
  7. [000370] Создание индекса во время выполнения программы
  8. [000462] Проверка изменения данных таблицы
  9. [000464] Очистка таблицы (с проверкой)
  10. [000513] Создание таблицы по образу и подобию
  11. [000555] Текущая TTable пуста?
  12. [000620] Пример SetText/GetText строкового поля
  13. [000874] Использование DBIopenlocklist

[ Компоненты ][ TabSet ]

  1. [000537] Перемещение на страницу Tabset по имени

[ Компоненты ][ TreeView ]

  1. [000054] Ускорение работы TreeView

[ Компоненты ][ Разное ]

  1. [000055] Массив компонентов I
  2. [000188] Массив компонентов II
  3. [000428] Массив компонентов III
  4. [000056] Получение индекса компонента в списке родителя
  5. [000057] Создание компонента во время работы приложения
  6. [000058] Дублирование компонентов и их потомков во время выполнения приложения I
  7. [000644] Дублирование компонентов и их потомков во время выполнения приложения II
  8. [000266] Компонент TrayIcon
  9. [000267] Информация о версии (Version Info) в Delphi EXE
  10. [000323] Исходные файлы VCL
  11. [000414] Вложенные свойства
  12. [000470] Прерывание создания компонента
  13. [000493] Чтение и запись компонента
  14. [000516] Refresh или Repaint?
  15. [000546] Имя класса компонента и модуля
  16. [000547] Пример компонента "HotSpot"
  17. [000576] FileReaderWriter-поток
  18. [000606] Копирование компонента через TFileStream
  19. [000749] Прозрачный компонент
  20. [000762] Имплантация таймера в компонент
  21. [000836] Связывание строки и компонента
  22. [000888] Создание свойства-массива компонентов
  23. [000925] Компонент TMinMax
  24. [000926] Создание порядка компонент - решено!
  25. [000951] Показ всплывающих подсказок компонентов
  26. [000987] Элементы управления с автовыравниванием?

[ Классы ][ TApplication ]

  1. [000396] Деактивация приложения
  2. [000401] Загрузка иконки
  3. [000485] Для чего нужен ProcessMessages?
  4. [000505] Окно активное и окно с фокусом

[ Классы ][ TColor ]

  1. [000478] Больше цветов!

[ Классы ][ TForm ]

  1. [000092] Delphi-приложения без форм?
  2. [000093] Показ логотипа при запуске приложения I
  3. [000747] Показ логотипа при запуске приложения II
  4. [000094] Перемещение формы не за заголовок I
  5. [000895] Перемещение формы не за заголовок II
  6. [000096] Помещение VCL компонентов в область заголовка?
  7. [000097] Сохранение TForm и/или ее свойств в BLOB-поле
  8. [000098] Удаление иконки из панели задач
  9. [000099] Как мне спрятать заголовок формы??
  10. [000100] Плавающие панельки
  11. [000101] Как мне узнать, что форма "готовится" изменить размеры?
  12. [000102] Предотвращение изменения вертикальных размеров окна
  13. [000103] Предотвращение изменения размеров формы
  14. [000105] Центрирование формы
  15. [000106] Окно произвольной формы?
  16. [000118] Добавление своих пунктов меню в системное меню окна
  17. [000163] Скрытие дочерних MDI-форм
  18. [000164] Просто одно дочернее MDI-окно?
  19. [000165] Придание MDI-формам большей "трехмерности"
  20. [000166] Заполнение изображением MDI-формы I
  21. [000612] Заполнение изображением MDI-формы II
  22. [000893] Заполнение изображением MDI-формы III
  23. [000167] Удаление заголовка у дочерней MDI-формы
  24. [000169] Проблема закрытия дочернего MDI-окна
  25. [000170] Фон MDI-окон
  26. [000271] Минимизирование формы при запуске
  27. [000274] Как сделать главную форму полностью невидимой??
  28. [000275] ПОМОГИТЕ !! STAY-ON-TOP !!!
  29. [000277] Обработка запроса на максимальное раскрытие окна
  30. [000283] Сохранение размеров, позиции и состояния окна
  31. [000286] Как сделать окно системно-модальным?
  32. [000299] Процедура автоматического масштабирования
  33. [000317] Круглый логотип при запуске приложения
  34. [000341] Иконка свернутого окна
  35. [000342] Размер/позиция MDI-окна
  36. [000353] Окно без заголовка
  37. [000354] Текущая позиция окна
  38. [000356] Режимы разрешения для формы
  39. [000387] Маленькая область заголовка
  40. [000387] Плавающая палитра
  41. [000415] "Трехмерные" формы с изменяющимися размерами
  42. [000433] Масштабирование окна I
  43. [000626] Масштабирование окна II
  44. [000449] Замена Form на FormIni
  45. [000460] Как сделать прозрачную форму
  46. [000479] Показ/скрытие дочерних MDI-окон
  47. [000535] Использование события OnHint во многих формах
  48. [000557] Кнопка заголовка активного окна
  49. [000572] Форма постоянно сверху приложения?
  50. [000596] Невидимые формы в EXE и DLL
  51. [000601] Косвенный вызов формы
  52. [000609] Показ формы без фокуса
  53. [000667] Создание синего экрана установки
  54. [000688] Универсальный создатель формы
  55. [000816] Создание формы переменного типа
  56. [000831] Позиция дочерних MDI-окон
  57. [000835] Показ окна без главной формы
  58. [000862] Изменение модального статуса формы
  59. [000876] Восстановление размера окна
  60. [000889] Динамическое создание формы
  61. [000935] Как заполнить фон моей формы повторяющимся изображением?
  62. [000972] Форма Delphi на панели задач

[ Классы ][ TCustomEdit ]

  1. [000109] Поиск строки текста в наследниках TCustmoEdit

[ Классы ][ TDataLink ]

  1. [000751] Информация о TDataLink

[ Классы ][ TFileStream ]

  1. [000521] Dos Copy через TFileStream

[ Классы ][ THandle ]

  1. [000112] Канва THandle (для метафайлов)

[ Классы ][ TMetafile ]

  1. [000332] TMetafile - ошибка при работе с памятью

[ Классы ][ TParser ]

  1. [000357] Недокументированный TParser
  2. [000435] Использование TParser
  3. [000508] Пример TParser
  4. [000666] Простое использование TParser

[ Классы ][ TRegIniFile ]

  1. [000902] Подсказка по работе TRegIniFile
  2. [000963] Использование TRegIniFile

[ Классы ][ TStream ]

  1. [000248] Сохранение и чтение из потока данных объекта
  2. [000918] Ошибка чтения потока

[ Классы ][ TStringList ]

  1. [000223] TStringList в TIniFile
  2. [000444] Сортировка TStringList
  3. [000633] PChar в TStringList
  4. [000663] Создание списка списков (TStringList)
  5. [000665] TstringList, владеющий объектами
  6. [000977] TstringList и потоки

[ Классы ][ TWriter ]

  1. [000645] Пример TWriter/TReader

[ Классы ][ Разное ]

  1. [000265] Высокоточный таймер

[ События ][ Создание ]

  1. [000059] Создание события во время выполнения приложения
  2. [000670] Имитация события MouseOff
  3. [000763] Назначение события во время выполнения программы
  4. [000797] Декларация события OnPassword

[ События ][ Задержка выполнения ]

  1. [000060] Задержка выполнения OnChange (Delphi 2)
  2. [000264] Организация задержки I
  3. [000652] Организация задержки II
  4. [000316] Работа в фоне

[ События ][ Разное ]

  1. [000671] Делегирование события
  2. [000695] Получение имени обработчика события
  3. [000788] Синтаксис ссылки на событие

[ Миграция ][ Delphi2 ]

  1. [000923] Совместное использование Delphi 1.0 и 2.0

[ Миграция ][ Delphi3 ]

  1. [000061] Получение констант с определением ошибки функцией LoadStr

[ Миграция ][ InterBase ]

  1. [000699] Переход с Oracle на Interbase

[ Миграция ][ Visual Basic ]

  1. [000690] Visual Basic "Beep" в Delphi

[ Ошибки ][ Delphi1 ]

  1. [000319] Ошибка сохранения текста в Memo
  2. [000345] Ошибка метода ItemAtPos компонента ListBox
  3. [000350] Ошибка фунциии GetTextLen компонента Memo
  4. [000409] Ошибка фунциии Print.EndDoc
  5. [000424] Ошибка в DriveComboBox
  6. [000429] Ошибка прокручивания TOutLine
  7. [000450] Ошибка StringList.Find
  8. [000471] Компонент OpenDialog - ошибки и их исправление
  9. [000679] Неверная документация по THelpEvent
  10. [000680] Cannot optimize ...not EXE... (не могу оптимизировать... не EXE...)
  11. [000681] Конфликт с Lotus Notes
  12. [000682] Ошибка TOutline ChangeLevelBy
  13. [000694] Ошибка csDropDownList/csDropDown
  14. [000700] Ошибка DDE/WinWord
  15. [000704] Ошибка конфигурации BDE
  16. [000719] Ошибка диалога настройки принтера
  17. [000720] Ошибка TListBox MeasureItem
  18. [000727] Printer.Abort не работает...
  19. [000781] Ошибка Grid RangeSel+RowSel
  20. [000790] Ошибка в mmsystem.pas
  21. [000861] GPF c любым Memo
  22. [000864] Проблемы с диалогом печати (PrintDialog)
  23. [000891] Проблема фильтров в компоненте SaveDialog
  24. [000997] Ошибка объекта TListBox

[ Ошибки ][ Delphi2 ]

  1. [000062] Ошибка в руководстве "Getting Started" на странице 42
  2. [000916] Распределение памяти TstringList
  3. [000917] Ошибка TQuery в Delphi 2
  4. [000921] Delphi 2.0 и оболочка Win95
  5. [000929] Проблема с HeapAlloc
  6. [000959] Проблемы с FORMS.PAS 2.0
  7. [000961] Проблема Reset текстового файла
  8. [000979] Ошибка в модуле Math
  9. [000986] Связь TDBMemo и StringField
  10. [000989] Ошибка в 32-битном StringGrid

[ Ошибки ][ Исключения ]

  1. [000084] Исключения в Delphi
  2. [000131] Номера ошибок
  3. [000425] Перехват ошибки

[ OLE+ ][ DCOM ]

  1. [000073] DCOM
  2. [000143] Отклик 1 - Сергей Качалов
  3. [000507] Отклик 2 - Василий Цыхмыстро

[ OLE+ ][ DDE ]

  1. [000486] Получение данных из Program Manager через DDE

[ OLE+ ][ COM ]

  1. [000221] Как зарегистрировать OCX?
  2. [000262] COM
  3. [000908] Delphi 2.0 & COM объекты

[ OLE+ ][ OLE ]

  1. [000189] OLE тестер
  2. [000510] Динамическое OLE
  3. [000577] Чтение сложных OLE-документов
  4. [000882] Application.Initialize
  5. [000885] Интерфейс OLE AutoServer

[ DLL ][ C++ ]

  1. [000075] Вызов Delphi DLL из MS Visual C++

[ DLL ][ Память ]

  1. [000272] Общий доступ к памяти, распределенной DLL
  2. [000808] Сегменты данных DLL

[ DLL ][ Ошибки ]

  1. [000443] DLL и ресурсы

[ DLL ][ Разное ]

  1. [000082] FTP4W32.DLL и Delphi 2.0
  2. [000504] Пример обратного вызова DLL
  3. [000726] Динамическое использование DLL
  4. [000742] Помещение формы в DLL
  5. [000807] Перехват вызовов функций из динамических библиотек
  6. [000837] Закрытие файла, открытого в DLL
  7. [000878] Соглашения о вызовах DLL I
  8. [000922] Соглашения о вызовах DLL II
  9. [000886] Потоки и DLL
  10. [000914] Синтаксис вызова DLL
  11. [000948] Простой пример DLL

[ Продукты третьих фирм ][ Microsoft Office ]

  1. [000187] Delphi / MS Office 97 / OLE / VB для приложений

[ Продукты третьих фирм ][ Microsoft Excel ]

  1. [000196] Excel
  2. [000198] Delphi и OLE Automation с Excel
  3. [000845] Пересылка данных в ячейки Excel

[ Продукты третьих фирм ][ Microsoft Exchange ]

  1. [000311] MAPI и MS Exchange

[ Продукты третьих фирм ][ Microsoft Word ]

  1. [000190] Получение данных из Delphi-приложения в документе Word
  2. [000191] WordBasic через OLE
  3. [000192] Создание документов Word
  4. [000193] Запуск Word без автостартующего (AutoStart) макроса
  5. [000194] Wordbasic с параметрами из Delphi
  6. [000195] Надоел ReportSmith? Хотите, чтобы у вас были WYSIWYG отчеты?
  7. [000197] Delphi + WordBasic 8
  8. [000199] Delphi и OLE Automation с Word
  9. [000552] Вызов MS Word из Delphi
  10. [000570] WinWord через DDE

[ Продукты третьих фирм ][ Quick Report ]

  1. [000217] Проблемы со шрифтами у QuickReport
  2. [000218] Заголовок окна предварительного просмотра Quick Report
  3. [000219] Переключение принтеров при печати в QuickReport

[ Продукты третьих фирм ][ ReportSmith ]

  1. [000227] Передача переменных отчета в ReportSmith I
  2. [000941] Передача переменных отчета в ReportSmith II
  3. [000735] ReportSmith и пароль
  4. [000847] Пропуск заставки ReportSmith

[ Продукты третьих фирм ][ WordPerfect ]

  1. [000701] Пример DDE & WordPerfect

[ Разное ][ Графика ]

  1. [000108] Заголовок TGA-файла
  2. [000110] *** Рисование КРИВЫХ в Delphi? ***
  3. [000120] Несколько программ для работы с точечной графикой (2D и 3D)
  4. [000122] Поворот изображения на 90 градусов
  5. [000123] Bitmap.Scanline для PixelFormat=pf1bit, pf8bit, pf24bit
  6. [000124] Гауссово размывание (Gaussian Blur) в Delphi
  7. [000814] Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки
  8. [000469] Рисование фрактальных графов
  9. [000598] Растягивание иконки
  10. [000654] Код создания палитры
  11. [000684] Рисование без мерцания
  12. [000689] Функция для работы с палитрами и RGB
  13. [000709] Загрузка 256-цветного TBitmap
  14. [000715] Вращение изображения
  15. [000717] Отображение ломанной линии
  16. [000784] Компонент для отрисовки линий
  17. [000785] Создание DIB из BMP
  18. [000786] TImage - эффект плавного перехода
  19. [000826] Создание и использование 256-цветной палитры
  20. [000827] Изменение цветовой палитры изображения
  21. [000910] Bitmap без формы
  22. [000912] Захват изображений
  23. [000915] Проблема с классом TBitmap
  24. [000974] Двоичный файл с набором изображений

[ Разное ][ Файлы помощи ]

  1. [000127] Оглавление файлов помощи (Help Files Contents)
  2. [000128] Как мне привязать файлы помощи в Delphi 3?
  3. [000524] Показ диалога "Help Search" I
  4. [000590] Показ диалога "Help Search" II
  5. [000770] Использование файла помощи
  6. [000879] Закрытие файла помощи

[ Разное ][ IDE ]

  1. [000129] Вывод окна CPU (дизассемблер)
  2. [000133] Общий доступ к Хранилищу Объектов (ObjectRepository)
  3. [000134] Как мне обнаружить, что программа запущена из-под IDE?
  4. [000259] Регулярные выражения
  5. [000293] Дата компилляции
  6. [000327] Потеря сохраненных файлов?
  7. [000336] Проблемы с цветами в IDE
  8. [000337] Outline ошибка
  9. [000338] Шрифты редактора Delphi
  10. [000360] Размер библиотек и скорость загрузки IDE
  11. [000437] Проблема блокировки ресурсов
  12. [000438] Поиск процедуры/функции в IDE
  13. [000441] Перехват IDE
  14. [000456] IDE: шрифт по умолчанию
  15. [000604] Определение работы Delphi I
  16. [000748] Определение работы Delphi II
  17. [000650] Имитация Delphi IDE
  18. [000777] Запуск Delphi с CD-ROM
  19. [000834] Удаление Delphi 1
  20. [000993] Невидимые элементы управления

[ Разное ][ Компилятор ]

  1. [000494] Директивы компилятора, способные увеличить скорость

[ Разное ][ Отладка ]

  1. [000395] Hard mode без перерыва
  2. [000410] Вывод объекта отладки

[ Разное ][ Ресурсы ]

  1. [000228] Таблицы строк
  2. [000229] Включение JPEG в EXE-файл
  3. [000244] Проигрывание wave-файла, помещенного в ресурс
  4. [000303] Несколько иконок в Delphi exe?
  5. [000309] Мультиязыковое приложение
  6. [000431] Загрузка строк из RES-файла
  7. [000492] Сохранение ресурсов системы
  8. [000773] Преобразование 16-битного DCR в 32-битный
  9. [000840] Загрузка изображения/курсора из RES-файла
  10. [000842] Эксперт ресурсов
  11. [000854] Создание RES-файла с помощью BRCC.EXE
  12. [000855] Сохранение пользовательских настроек
  13. [000907] 16/32-битные RES-файлы
  14. [000964] Хранение данных в EXE-файле

[ Разное ][ Защита ]

  1. [000298] Пример защиты типа SHAREWARE
  2. [000806] Как стереть самого себя
  3. [000817] Защита программ перекрытием кода

[ Разное ][ Разное ]

  1. [000130] Каталог вашего приложения I
  2. [000446] Каталог вашего приложения II
  3. [000746] Каталог вашего приложения III
  4. [000913] Каталог вашего приложения IV
  5. [000132] 16-разрядные приложения в Delphi 2-Х??
  6. [000135] Как мне создать Internet-ссылку в диалоге "О программе"?
  7. [000168] Меню дочерних MDI-форм
  8. [000263] Как осуществить задержку, не используя 100% времени CPU?
  9. [000347] Мемуары
  10. [000500] Powersoft против Delphi
  11. [000578] FAQ 1, Не-технический
  12. [000579] FAQ 3, установка
  13. [000581] FAQ 4, IDE
  14. [000892] FAQ 5 VCL (1 из 2)
  15. [000894] FAQ 5 VCL (2 из 2)
  16. [000582] FAQ 6, Базы данных
  17. [000583] FAQ 7, Объектный паскаль
  18. [000584] FAQ 8, VBX
  19. [000585] FAQ 9, Компоненты
  20. [000586] FAQ 14 - Windows API
  21. [000586] FAQ 15 - Отладка/Утилиты
  22. [000674] FAQ 20 - Сети
  23. [000896] Детальное описание DELPHI.INI (1 из 2)
  24. [000898] Детальное описание DELPHI.INI (2 из 2)
  25. [000934] Установка Delphi в сети
  26. [000648] Сущность ООП
  27. [000660] Список зависимых файлов
  28. [000736] Проблема видеокарточки в Win95
  29. [000745] Миниатюрное Delphi-приложение
  30. [000859] Исследование кода, генерируемого Delphi


 Лицензионное соглашение

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

Предоставление лицензии

B
алентин Озеров предоставил Вам ограниченную лицензию на "Советы по Delphi". Она НЕ ВКЛЮЧАЕТ В СЕБЯ лицензию на изменение, транслирование, перепроектирование, декомпилирование, дизассемблирование (за исключением случаев, когда соответствующие законы специально запрещают такое ограничение), или создание других программных продуктов, основанных на этом.

Особые условия

Ограничение на обратное конструирование, декомпиляцию и дизассемблирование.

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

T
ак как все программное обеспечение бесплатно, компания Mechanical Result и автор не несут ответственности за любые последствия использования данного программного обеспечения на вашем компьютере. Советы по Delphi распространяется по принципу "КАК ЕСТЬ", т.е. без гарантий любого вида, включая отсутствие гарантии на соответствие указанным задачам и отсутствие сбоев. Весь риск относительно качества и эффективности программного обеспечения лежит на Вас. Если использование данной программы приведет к проблемам, Вы принимаете на себя всю стоимость любого обслуживания и ремонта.

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

Распространение

В
ы свободны в распространении Советов по Delphi на любом общественном (открытом) Web/FTP/Gopher сервере без обязательного получения разрешения автора, пока это распространение проводится АБСОЛЮТНО БЕСПЛАТНО. Если Вы хотите издать данный продукт на или совместно с любым носителем (например, на компакт диске с журналом или книгой, на любой коллекции программного обеспечения, совместно с другим программным обеспечением или любым другим дистрибутивным пакетом), требуется разрешение автора. Обычно разрешение может быть получено без проблем - свободно, за исключением некоторых особых случаев.

Помните

В
алентин Озеров - единственый человек, который может дать разрешение на коммерческое использование и распространение справочной системы Советы по Delphi.

E
ЕСЛИ ВЫ НЕ ПОНИМАЕТЕ КАКОЙ-ЛИБО ЧАСТИ ДАННОГО ЛИЦЕНЗИОННОГО СОГЛАШЕНИЯ ИЛИ ВСЕГО СОГЛАШЕНИЯ В ЦЕЛОМ, СВЯЖИТЕСЬ СО МНОЙ ПО ЭЛЕКТРОННОЙ ПОЧТЕ ИЛИ ЛЮБЫМ ДРУГИМ СПОСОБОМ, ЧТОБЫ Я МОГ ОБЪЯСНИТЬ ИХ ВАМ.


HEX -> Integer

Решение 1

var
i : integer
s : string;
begin
s := '$' + ThatHexString;
i := StrToInt(a);
end;

Решение 2

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.
[000001]


Преобразование десятичного числа в шестнадцатиричное

Самое простое преобразование - через строку.

HexString := Format('%0x',[DecValue]);

Спасибо за ценное замечание Дмитрию Каширину.

SottNick возражает:

Самое простое преобразование - через строку.

HexString := IntToHex( [DecValue] , [MinDigits] );
[000002]


Преобразование ASCII в шестнадцатиричное представление

Строка представляет собой массив байтов в виде ASCII-символов. Необходимо организовать преобразование типов по аналогии с Delphi-функциями Ord и Chr.

Функция BytesToHexStr преобразует, к примеру, набор байтов [0,1,1,0] в строку '30313130', HexStrToBytes выполнит обратное преобразование.

unit Hexstr;

interface
uses String16, SysUtils;

Type
PByte = ^BYTE;

procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);
procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

implementation
procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);
Const

HexChars : Array[0..15] of Char = '0123456789ABCDEF';
var
i, j: WORD;
begin
SetLength(hHexStr, (InputLength * 2));
FillChar(hHexStr, sizeof(hHexStr), #0);
j := 1;
for i := 1 to InputLength  do begin
hHexStr[j] := Char(HexChars[pbyteArray^ shr  4]); inc(j);
hHexStr[j] := Char(HexChars[pbyteArray^ and 15]); inc(j);
inc(pbyteArray);
end;
end;

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);
var
i: WORD;
c: byte;
begin
SetLength(Response, InputLength);
FillChar(Response, SizeOf(Response), #0);
for i := 0 to (InputLength - 1) do begin
c := BYTE(hexbytes[i]) And BYTE($f);
if c > 9 then
Inc(c, $37)
else
Inc(c, $30);
Response[i + 1] := char(c);
end;{for}
end;

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);
{pbyteArray указывает на область памяти, хранящей результаты}
var
i, j: WORD;
tempPtr: PChar;
twoDigits : String[2];
begin
tempPtr := pbyteArray;
j := 1;
for i := 1 to (Length(hHexStr) DIV 2) do begin
twoDigits := Copy(hHexStr, j, 2); Inc(j, 2);
PByte(tempPtr)^ := StrToInt('$' + twoDigits); Inc(tempPtr);
end;{for}
end;

end.

UNIT String16.
interface
{$IFNDEF Win32}
procedure SetLength(var S: string; Len: Integer);
procedure SetString(var Dst: string; Src: PChar; Len: Integer);
{$ENDIF}
implementation
{$IFNDEF Win32}
procedure SetLength(var S: string; Len: Integer);
begin
if Len > 255 then
S[0] := Chr(255)
else
S[0] := Chr(Len)
end;

procedure SetString(var Dst: string; Src: PChar; Len: Integer);
begin
if Len > 255 then
Move(Src^, Dst[1], 255)
else
Move(Src^, Dst[1], Len);
SetLength(Dst, Len);
end;
{$ENDIF}
end.
[000003]


Преобразование двоичного числа в десятичное

Может ли кто-нибудь дать мне идею простого преобразования двоичного кода (base2) в десятичный (base10)?

Решение 1

/////////////////////////////////////////////////////////////////////////
// преобразование 32-битного base2 в 32-битный base10                  //
// максимальное число = 99 999 999, возвращает -1 при большем значении //
/////////////////////////////////////////////////////////////////////////

function Base10(Base2:Integer) : Integer; assembler;
asm
cmp        eax,100000000        // проверка максимального значения
jb         @1                   // значение в пределах допустимого
mov        eax,-1               // флаг ошибки
jmp        @exit                // выход если -1
@1:
push       ebx                  // сохранение регистров
push       esi
xor        esi,esi              // результат = 0
mov        ebx,10               // вычисление десятичного логарифма
mov        ecx,8                // преобразование по формуле 10^8-1
@2:
mov        edx,0                // удаление разницы
div        ebx                  // eax - целочисленное деление на 10, edx - остаток от деления на 10
add        esi,edx              // результат = результат + разность[I]
ror        esi,4                // перемещение разряда
loop       @2                   // цикл для всех 8 разрядов
mov        eax,esi              // результат функции
pop        esi                  // восстанавление регистров
pop        ebx
@exit:
end;

Решение 2

function IntToBin(Value: LongInt;Size: Integer): String;
var
i: Integer;
begin
Result:='';
for i:=Size downto 0 do begin
if Value and (1 shl i)<>0 then begin
Result:=Result+'1';
end else begin
Result:=Result+'0';
end;
end;
end;

function BinToInt(Value: String): LongInt;
var
i,Size: Integer;
begin
Result:=0;
Size:=Length(Value);
for i:=Size downto 0 do begin
if Copy(Value,i,1)='1' then begin
Result:=Result+(1 shl i);
end;
end;
end;

Решение 3

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

function DecToBase( Decimal: LongInt; const Base: Byte): String;
const
Symbols: String[16] = '0123456789ABCDEF';
var
scratch: String;
remainder: Byte;
begin
scratch := '';
repeat
remainder := Decimal mod Base;
scratch := Symbols[remainder + 1] + scratch;
Decimal := Decimal div Base;
until ( Decimal = 0 );
Result := scratch;
end;

Передайте данной функции любую десятичную величину (1...3999), и она возвратит строку, содержащую точное значение в римской транскрипции.

function DecToRoman( Decimal: LongInt ): String;
const
Romans: Array[1..13] of String =
( 'I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M' );

Arabics: Array[1..13] of Integer =
( 1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var
i: Integer;
scratch: String;
begin
scratch := '';
for i := 13 downto 1 do
while ( Decimal >= Arabics[i] ) do
begin
Decimal := Decimal - Arabics[i];
scratch := scratch + Romans[i];
end;
Result := scratch;
end;
[000004]


Преобразование ICO в BMP I

Решение 1

Попробуйте:

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;

Решение 2

Способ преобразования изображения размером 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.
[000005]


Преобразование ICO в BMP II

A.Astafiev@ftc.ru советует:

Чтобы преобразовать 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;

[000909]


Перевод из BitMap в Icon

...(Ваша старая программа вроде не работает) Нужно создать два bitmap, маску (называемую "AND") и bitmap с картинкой (называемый "XOR" bitmap). Можно передать handles к "AND" и "XOR" bitmap Windows API функции CreateIconIndirect() ииспользовать полученный handle иконки в вашем приложении

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);

{Удаляем временные bitmap}
AndMask.Free;
XOrMask.Free;

{Рисуем для проверки}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Присвамваем иконку приложению}
Application.Icon := Icon;

{Заставляем перерисоваться}
InvalidateRect(Application.Handle, nil, true);

{Освобождаем иконку}
Icon.Free;
end;

Прислал Alexander Vozny. [000461]


Unix-строки (чтение и запись 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.
[000006]


Преобразование BMP в JPEG в Delphi 3

Используя Delphi 3, как мне сохранить BMP-изображение в JPEG-файле?

Допустим, Image1 - компонент TImage, содержащий растровое изображение. Используйте следующий фрагмент кода для конвертации вашего изображения в JPEG-файл:

var
MyJpeg: TJpegImage;
Image1: TImage;
begin
Image1:= TImage.Create;
MyJpeg:= TJpegImage.Create;
Image1.LoadFromFile('TestImage.BMP');  // Чтение изображения из файла
MyJpeg.Assign(Image1.Picture.Bitmap);  // Назначание изображения объекту MyJpeg
MyJpeg.SaveToFile('MyJPEGImage.JPG');  // Сохранение на диске изображения в формате JPEG
end;
[000007]


Декомпилляция звукового файла формата 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}
[000008]


Преобразование '1010' в '001010'

Решением является создание функции, функционально похожей на функцию Clipper - PadL(string,width,character):

function TfrmFunc.PadL(cVal: string; nWide: integer; cChr: char): string;
var
i1,nStart: integer;
begin
if length(cVal) < nWide then
begin
nStart:=length(cVal);
for i1:=nStart to nWide-1 do cVal:=cChar+cVal;
end;
PadL:=cVal;
end;

Затем это может вызываться c любой строкой, которой вы хотите задать определенную длину. Пользуйтесь функцией также, как вы привыкли пользоваться прежней - PadL(A,length(B),'0'); Она имеет большую гибкость - возможно заполнение любым символом до необходимой длины (удобно для задания текстовых счетчиков с фиксированным количеством символов -- PadL(A,6,'0').

Дополнение

Good_mag пишет:

Мне очень нравится Ваше издание, но вот встретил одно решение, которое не очень мне понравилось. Оно правильное, но довольно длинное.

Вот мой вариант этого решения, он короче предыдущего:

function PadL(s_InStr: string; i_Wide: integer; c_Chr: char): string;
begin
while Length(s_InStr) < i_Wide  do  s_InStr := c_Chr + s_InStr;
Result := s_InStr;
end;
[000155]


Число строкой I

Данный код "считает" до миллиона долларов. Поэкспериментируйте с ним - попробуйте "посчитать" до миллиарда, конвертировать ее в рубли или переделать ее для работы с русским языком. Только не забудьте прислать мне ваши решения!

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.

[000158]


Число строкой II

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

Валентин!

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

Александр

{------------------------ Деньги прописью ---------------------}
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;

[000230]


Число строкой III

Вот еще одно решение, присланное читателем.

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.

[000237]


Число строкой IV

Вот еще одно решение, присланное читателем.

Уважаемый Валентин!

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

Редянов Денис

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;

[000240]


Число строкой V

Вот еще одно решение, присланное Олегом Клюкач.

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.

[000243]


Число строкой VI

Еще два решения конвертации денежной суммы на английском языке

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 ≶ 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;

[000256]


Число строкой VII

Здравствуйте Валентин.

Честно, давно ждал подобного журнала в электронном виде. Решил послать своё творчество которое уже немало отработало, опять же, преобразование числа в пропись, отличающееся от опубликованных программок тем, что слова для прописи хранятся в отдельном файле (lang.cnf), по аналогии с подуктами 1C. Это позволяет изменять национальную валюту.

Если поэкспериментировать, с массивом Univer, в котором хранятся окончания, можно добиться преобразования для многих языков, не сказал ли я чего лишнего. :)

Надеюсь, моя версия Вам понравится.

С наилучшими пожеланиями,

Панченко Сергей

Казахстан, Алматы,

Sergey@arna.kz

BuchUtil.pas

unit BuchUtil;

interface

uses IniFiles, SysUtils;

function DoubleChar(ch: string): string;
function NumToSampl(N:  string): string;
function MoneyToSampl(M: Currency): string;
procedure LexemsToDim(fstr: string; var dim: array of string);

var
NameNum: array[0..9, 1..4]of string;//массив имён чисел
Ext: array[0..4, 1..3]of string;    //массив расшиений (тысячи, миллионы ...)
Univer: array[1..9, 1..4]of integer;//массив окончаний
Rubl: array[1..3]of String;         //массив имен рублей
Cop: array[1..3]of String;          //массив имен копеек
Zero: string;                       //название нуля
One: string;                        //единица "одна"
Two: string;                        //двойка "две"
fFile: TIniFile;                    //файл, откуда загружается пропись
fString: string;
fDim: array [0..9] of string;
i: integer;

implementation

{заполняет массив Dim лексемами}
procedure LexemsToDim(fstr: string; var dim: array of string);
var
i, j: integer;
flex: string;
begin
if Length(fstr)>0 then
begin
i:=1;
j:=0;
while i-1<Length(fstr) do
begin
if fstr[i]=',' then
begin
dim[j]:=flex+' ';
inc(j);
flex:='';
end
else
flex:=flex+fstr[i];
inc(i);
end;
end;
end;

{преобразует число в пропись
процедура использует файл lang.cnf}
 function NumToSampl(N:  string): string;
var
k, i, i_indx: integer;
number, string_num: string;
index: integer;
pos: integer;
fl_ext: boolean;
begin
fl_ext:=true;
i:=1;
String_num:='';
number:=Trim(N);
k:=length(number);
if (k=1)and(number='0')then String_num:=Zero
else begin
pos:=0;
while (k>0) do begin
if (k<>1)and(i=1)and(length(number)<>1)and(copy(number,k-1,1)='1')
and(copy(number,k,1)<>'0') then begin
index:=StrToInt(copy(number,k,1));
dec(k);
inc(i);
i_indx:=4;
end
else begin
index:=StrToInt(copy(number,k,1));
i_indx:=i;
end;
if (NameNum[index,i_indx]<>'')and(fl_ext=true)then begin
String_num:=Ext[pos,Univer[index,i_indx]]+String_num;
fl_ext:=false;
end;

if (index=1)and(pos=1)and(i=1)then
String_num:=One+String_num
else if (index=2)and(pos=1)and(i=1)then
String_num:=Two+String_num
else
String_num:=NameNum[index,i_indx]+String_num;
inc(i);
if i=4 then begin
i:=1;
inc(pos);
fl_ext:=true
end;
dec(k);
end;
end;
if Trim(String_Num)<>'' then
begin
String_num[1]:=CHR(ORD(String_num[1])-32);
Result:=String_num;
end;
end;

{Преобразует х в 0х}
function DoubleChar(ch: string): string;
begin
if Length(ch)=1 then
Result:='0'+ch
else
Result:=ch;
end;

{преобразует денежную сумму в пропись}
function MoneyToSampl(M: Currency): string;
var
Int_Part, idx, idxIP, idxRP: integer;
Int_Str, Real_Part, Sampl: string;
begin
Int_Part:=Trunc(Int(M));
Int_Str:=IntToStr(Int_Part);
Real_Part:=DoubleChar(IntToStr(Trunc(Int((M-Int_Part+0.001)*100))));
Sampl:=NumToSampl(Int_Str);
idx:=StrToInt(Int_Str[Length(Int_Str)]);
if idx=0 then idx:=5;
idxIP:=Univer[idx, 1];
idx:=StrToInt(Real_Part[Length(Real_Part)]);
if idx=0 then idx:=5;
idxRP:=Univer[idx, 1];
Result:=Sampl+Rubl[idxIP]+Real_Part+' '+Cop[idxRP];
end;

Initialization
{Предположим файл находится на C:\ диске}
fFile:=TIniFile.Create('c:\lang.cnf');
try
{Заполнение массива рублей}
fString:=fFile.ReadString('Money', 'Rub', ',');
LexemsToDim(fString, Rubl);

{Заполнение массива копеек}
fString:=fFile.ReadString('Money', 'Cop', ',');
LexemsToDim(fString, Cop);

{Заполнение массива чисел}
fString:=fFile.ReadString('Nums', 'Numbers', ',');
LexemsToDim(fString, fdim);
NameNum[0, 1]:='';
for i:=1 to 9 do
NameNum[i, 1]:=fdim[i-1];

{Заполнение массива десятков}
fString:=fFile.ReadString('Nums', 'Tens', ',');
LexemsToDim(fString, fdim);
NameNum[0, 2]:='';
for i:=1 to 9 do
NameNum[i, 2]:=fdim[i-1];

{Заполнение массива сотен}
fString:=fFile.ReadString('Nums', 'Hundreds', ',');
LexemsToDim(fString, fdim);
NameNum[0, 3]:='';
for i:=1 to 9 do
NameNum[i, 3]:=fdim[i-1];

{Заполнение массива чисел после десяти}
fString:=fFile.ReadString('Nums', 'AfterTen', ',');
LexemsToDim(fString, fdim);
NameNum[0, 4]:='';
for i:=1 to 9 do
NameNum[i, 4]:=fdim[i-1];

{Заполнение расширений чисел}
Ext[0,1]:='';
Ext[0,2]:='';
Ext[0,3]:='';

{Тысячи}
fString:=fFile.ReadString('Nums', 'Thou', ',');
LexemsToDim(fString, fdim);
for i:=1 to 3 do
Ext[1, i]:=fdim[i-1];

{Миллионы}
fString:=fFile.ReadString('Nums', 'Mill', ',');
LexemsToDim(fString, fdim);
for i:=1 to 3 do
Ext[2, i]:=fdim[i-1];

{Миллиарды}
fString:=fFile.ReadString('Nums', 'Bill', ',');
LexemsToDim(fString, fdim);
for i:=1 to 3 do
Ext[3, i]:=fdim[i-1];

{Триллион}
fString:=fFile.ReadString('Nums', 'Thrill', ',');
LexemsToDim(fString, fdim);
for i:=1 to 3 do
Ext[4, i]:=fdim[i-1];

Zero:=fFile.ReadString('Nums', 'Zero', '0');
if Zero[Length(Zero)]=',' then
Zero:=Copy(Zero, 1, Length(Zero)-1)+' ';

One:=fFile.ReadString('Nums', 'One', '1');
if One[Length(One)]=',' then
One:=Copy(One, 1, Length(One)-1)+' ';

Two:=fFile.ReadString('Nums', 'Two', '0');
if Two[Length(Two)]=',' then
Two:=Copy(Two, 1, Length(Two)-1)+' ';

{Заполнение таблицы окончаний}
Univer[1,1]:=1; Univer[1,2]:=2; Univer[1,3]:=2; Univer[1,4]:=2;
Univer[2,1]:=3; Univer[2,2]:=2; Univer[2,3]:=2; Univer[2,4]:=2;
Univer[3,1]:=3; Univer[3,2]:=2; Univer[3,3]:=2; Univer[3,4]:=2;
Univer[4,1]:=3; Univer[4,2]:=2; Univer[4,3]:=2; Univer[4,4]:=2;
Univer[5,1]:=2; Univer[5,2]:=2; Univer[5,3]:=2; Univer[5,4]:=2;
Univer[6,1]:=2; Univer[6,2]:=2; Univer[6,3]:=2; Univer[6,4]:=2;
Univer[7,1]:=2; Univer[7,2]:=2; Univer[7,3]:=2; Univer[7,4]:=2;
Univer[8,1]:=2; Univer[8,2]:=2; Univer[8,3]:=2; Univer[8,4]:=2;
Univer[9,1]:=2; Univer[9,2]:=2; Univer[9,3]:=2; Univer[9,4]:=2;
finally
fFile.Free;
end;

end.

Lang.cnf

[Nums]
Numbers=один,два,три,четыре,пять,шесть,семь,восемь,девять,
One=одна,
Two=две,
Tens=десять,двадцать,тридцать,сорок,пятьдесят,шестьдесят,семьдесят,восемьдесят,девяносто,
Hundreds=сто,двести,триста,четыреста,пятьсот,шестьсот,семьсот,восемьсот,девятьсот,
AfterTen=одиннадцать,двенадцать,тринадцать,четырнадцать,пятнадцать,шестнадцать,семнадцать,восемнадцать,девятнадцать,
Zero=ноль,
Thou=тысяча,тысяч,тысячи,
Mill=миллион,миллионов,миллиона,
Bill=миллиард,миллиардов,миллиарда,
Thrill=триллион,триллионов,триллиона,

[Money]
Rub=рубль,рублей,рубля,
Cop=копейка,копеек,копейки,

[000562]


Число строкой VIII

function NumToStr(n: double; c: byte = 0): string;
(*
c=0 - 21.05 -> 'Двадцать один рубль 05 копеек.'
с=1 - 21.05 -> 'двадцать один'
c=2 - 21.05 -> '21-05', 21.00 -> '21='
*)
 const
digit: array[0..9] of string = ('ноль', 'оди', 'два', 'три', 'четыр',
'пят', 'шест', 'сем', 'восем', 'девят');
var
ts, mln, mlrd, SecDes: Boolean;
len: byte;
summa: string;

function NumberString(number: string): string;
var
d, pos: byte;

function DigitToStr: string;
begin
result := '';
if (d <> 0) and ((pos = 11) or (pos = 12)) then mlrd := true;
if (d <> 0) and ((pos = 8) or (pos = 9)) then mln := true;
if (d <> 0) and ((pos = 5) or (pos = 6)) then ts := true;
if SecDes then
begin
case d of
0: result := 'десять ';
2: result := 'двенадцать '
else result:=digit[d]+'надцать '
end;
case pos of
4: result := result + 'тысяч ';
7: result := result + 'миллионов ';
10: result := result + 'миллиардов '
end;
SecDes := false;
mln := false;
mlrd := false;
ts := false
end
else
begin
if (pos = 2) or (pos = 5) or (pos = 8) or (pos = 11) then
case d of
1: SecDes := true;
2, 3: result := digit[d] + 'дцать ';
4: result := 'сорок ';
9: result := 'девяносто ';
5..8: result := digit[d] + 'ьдесят '
end;
if (pos = 3) or (pos = 6) or (pos = 9) or (pos = 12) then
case d of
1: result := 'сто ';
2: result := 'двести ';
3: result := 'триста ';
4: result := 'четыреста ';
5..9: result:=digit[d]+'ьсот '
end;
if (pos = 1) or (pos = 4) or (pos = 7) or (pos = 10) then
case d of
1: result := 'один ';
2,3: result := digit[d] + ' ';
4: result := 'четыре ';
5..9: result := digit[d] + 'ь '
end;
if pos = 4 Then
begin
case d of
0: if ts then result := 'тысяч ';
1: result := 'одна тысяча ';
2: result := 'две тысячи ';
3,4: result := result + 'тысячи ';
5..9: result := result + 'тысяч '
end;
ts := false
end;
if pos = 7 then
begin
case d of
0: if mln then result := 'миллионов ';
1: result := result + 'миллион ';
2, 3, 4: result := result + 'миллиона ';
5..9: result := result + 'миллионов '
end;
mln := false
end;
if pos = 10 then
begin
case d of
0: if mlrd then result := 'миллиардов ';
1: result := result + 'миллиард ';
2, 3, 4: result := result + 'миллиарда ';
5..9: result := result + 'миллиардов '
end;
mlrd := false
end
end
end;

begin
result := '';
ts := false;
mln := false;
mlrd := false;
SecDes := false;
len := length(number);
if (len = 0) or (number = '0') then
result := digit[0]
else
for pos := len downto 1 do
begin
d := StrToInt(copy(number, len - pos + 1, 1));
result := result + DigitToStr
end
end;

function MoneyString(number: string): string;
var
s: string[1];
n: string;
begin
len := length(number);
n := copy(number, 1, len-3);
result := NumberString(n);
s := AnsiUpperCase(result[1]);
delete(result, 1, 1);
result := s + result;
if len < 2 then
begin
if len = 0 then n := '0';
len := 2;
n := '0' + n
end;
if copy(n, len - 1, 1) = '1' then
result := result + 'рублей'
else
begin
case StrToInt(copy(n, len, 1)) of
1: result := result + 'рубль';
2, 3, 4: result := result + 'рубля'
else result := result + 'рублей'
end
end;
len := length(number);
n := copy(number, len - 1, len);
if copy(n, 1, 1) = '1' then
n := n + ' копеек.'
else
begin
case StrToInt(copy(n, 2, 1)) of
1: n := n + ' копейка.';
2, 3, 4: n := n + ' копейки.'
else n := n + ' копеек.'
end
end;
result := result + ' ' + n
end;

// Основная часть
begin
case c of
0: result := MoneyString(FormatFloat('0.00', n));
1: result := NumberString(FormatFloat('0', n));
2: begin
summa := FormatFloat('0.00', n);
len := length(summa);
if copy(summa, len - 1, 2) = '00' then
begin
delete(summa, len - 2, 3);
result := summa + '='
end
else
begin
delete(summa, len - 2, 1);
insert('-', summa, len - 2);
result := summa;
end;
end
end;
end;

С уважением, Васильев Сергей Геннадьевич, Благовещенск, vs2000@mail.ru [000580]


Число строкой IX

Пришло от читателя письмо:

Посмотрел я что в разделе "Алгоритмы->Преобразование" много советов Число строкой, но нет преобразования на Украинский язык я подумал может модуль который я когда-то со славарем писал кому то спасет жизнь - так как у меня он уже года два работает.

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

ООО "Проект ВО"
Украина, г.Харьков. [000857]


Преобразование RTF в HTML

Мне нужно перевести содержимое компонента RTF в HTML с помощью Delphi. Кто-нибудь знает как это сделать?

Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

function rtf2sgml (text : string) : string;
{Funktion för 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 därför bort
det efter \fs16 och la istället en egen tvätt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang}
 text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få }
text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika}
{Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu städar vi istället bort alla tvåsiffriga 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>');
[000235]


Синтаксический анализ строки

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

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

Так, если у вас есть текст, содержащий слово Joe и вам необходимо заменить все вхождения этого слова на Joey, необходимо сделать две итерации, сначала:
text := stringreplaceall (text,'Joe','Joeey');
и затем
text := stringreplaceall (text,'Joeey','Joey');

unit sparfunc;

interface

uses sysutils,classes;

function antaltecken (orgtext,soktext : string) : integer;
function beginsWith (text,teststreng : string):boolean;
function endsWith (text,teststreng : string):boolean;
function hamtastreng (text,strt,slut : string):string;
function hamtastrengmellan (text,strt,slut : string):string;
function nastadelare (progtext : string):integer;
function rtf2sgml (text : string) : string;
Function sgml2win(text : String) : String;
Function sgml2mac(text : String) : String;
Function sgml2rtf(text : string) : String;
function sistamening(text : string) : string;
function stringnthfield (text,delim : string; vilken : integer) : string;
function stringreplace (text,byt,mot : string) : string;
function stringreplaceall (text,byt,mot : string) : string;
function text2sgml (text : string) : string;
procedure SurePath (pathen : string);
procedure KopieraFil (infil,utfil : string);
function LasInEnTextfil (filnamn : string) : string;

implementation

function LasInEnTextfil (filnamn : string) : string;
var
infil : textfile;
temptext, filtext : string;
begin
filtext := '';
//Öppna angiven fil och läs in den
try
assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname
reset (infil);             //Öppna filen
while not eof(infil) do begin    //Så länge vi inte nått slutet
readln (infil,temptext); //Läs in en rad
filtext := filtext+temptext; //Lägg den till variabeln SGMLTEXT
end; // while
finally  //slutligen
closefile (infil); //Stäng filen
end; //try
result := filtext;
end;

procedure KopieraFil (infil,utfil : string);
var
InStream : TFileStream;
OutStream : TFileStream;
begin
InStream := TFileStream.Create(infil,fmOpenRead);
try
OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate);
try
OutStream.CopyFrom(InStream,0);
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
end;

procedure SurePath (pathen : string);
var
temprad,del1 : string;
antal : integer;
begin
antal := antaltecken (pathen,'\');
if antal<3 then
createdir(pathen)
else  begin
if pathen[length(pathen)] <> '\' then pathen := pathen+'\';
pathen := stringreplace(pathen,'\','/');
del1 := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,del1,'');
del1 := stringreplace(del1,'/','\');
createdir (del1);
while pathen <> '' do begin
temprad := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,temprad,'');
del1 := del1+ temprad;
temprad := '';
createdir(del1);
end;
end;
end;

function antaltecken (orgtext,soktext : string) : integer;
var
i,traffar,soklengd : integer;
begin
traffar := 0;
soklengd := length(soktext);
for i := 1 to length(orgtext) do
begin
if soktext = copy(orgtext,i,soklengd) then
traffar := traffar +1;
end;
result := traffar;
end;

function nastadelare (progtext : string):integer;
var
i,j : integer;
begin
i := pos('.',progtext);
j := pos('!',progtext);
if (j<i) and (j>0) then i := j;
j := pos('!',progtext);
if (j<i) and (j>0) then i := j;
j := pos('?',progtext);
if (j<i) and (j>0) then i := j;
result := i;
end;

function stringnthfield (text,delim : string; vilken : integer) : string;
var
start,slut,i : integer;
temptext : string;
begin
start := 0;
if vilken >0 then
begin
temptext := text;
if vilken = 1 then
begin
start := 1;
slut := pos (delim,text);
end
else
begin
for i:= 1 to vilken -1 do
begin
start := pos(delim,temptext)+length(delim);
temptext := copy(temptext,start,length(temptext));
end;
slut := pos (delim,temptext);
end;
if start >0 then
begin
if slut = 0 then slut := length(text);
result := copy (temptext,1,slut-1);
end
else
result := text;
end
else
result := text;
end;

function StringReplaceAll (text,byt,mot : string ) :string;
{Funktion för att byta ut alla förekomster av en sträng mot en
annan sträng in en sträng. Den konverterade strängen returneras.
Om byt finns i mot måste vi gå via en temporär variant!!!}
 var
plats : integer;
begin
While pos(byt,text) > 0 do
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;

function StringReplace (text,byt,mot : string ) :string;
{Funktion för att byta ut den första förekomsten av en sträng mot en
annan sträng in en sträng. Den konverterade strängen returneras.}
 var
plats : integer;
begin
if pos(byt,text) > 0 then
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;

function hamtastreng (text,strt,slut : string):string;
{Funktion för att hämta ut en delsträng ur en annan sträng.
Om start och slut finns i text så returneras en sträng där start
ingår i början och fram till tecknet före slut.}
 var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats,length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;

function hamtastrengmellan (text,strt,slut : string):string;
{Funktion för att hämta ut en delsträng ur en annan sträng.
Om start och slut finns i text så returneras en sträng där start
ingår i början och fram till tecknet före slut.}
 var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats+length(strt),length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;

function endsWith (text,teststreng : string):boolean;
{Kollar om en sträng slutar med en annan sträng.
Returnerar true eller false.}
 var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd > testlngd then
begin
kollstreng := copy (text,(textlngd+1)-testlngd,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;

function beginsWith (text,teststreng : string):boolean;
{Funktion för att kolla om text börjar med teststreng.
Returnerar true eller false.}
 var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd >= testlngd then
begin
kollstreng := copy (text,1,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;

function sistamening(text : string) : string;
//Funktion för att ta fram sista meningen i en sträng. Söker på !?.
var
i:integer;
begin
i :=length(text)-1;
while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and (copy(text,i,1)<> '?') do
begin
dec(i);
if i =1 then break

end;
if i>1 then
result := copy(text,i,length(text))
else
result := '';
end;

Function text2sgml(text : String) : String; {Funktion som byter ut alla ovanliga tecken mot entiteter.
Den färdiga texten returneras.}
 begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&amp');
text := stringreplaceall (text,'å','&aring;');
text := stringreplaceall (text,'Å','&Aring;');
text := stringreplaceall (text,'ä','&auml;');
text := stringreplaceall (text,'Ä','&Auml;');
text := stringreplaceall (text,'á','&aacute;');
text := stringreplaceall (text,'Á','&Aacute;');
text := stringreplaceall (text,'à','&agrave;');
text := stringreplaceall (text,'À','&Agrave;');
text := stringreplaceall (text,'æ','&aelig;');
text := stringreplaceall (text,'Æ','&Aelig;');
text := stringreplaceall (text,'Â','&Acirc;');
text := stringreplaceall (text,'â','&acirc;');
text := stringreplaceall (text,'ã','&atilde;');
text := stringreplaceall (text,'Ã','&Atilde;');
text := stringreplaceall (text,'ç','&ccedil;');
text := stringreplaceall (text,'Ç','&Ccedil;');
text := stringreplaceall (text,'é','&eacute;');
text := stringreplaceall (text,'É','&Eacute;');
text := stringreplaceall (text,'ê','&ecirc;');
text := stringreplaceall (text,'Ê','&Ecirc;');
text := stringreplaceall (text,'ë','&euml;');
text := stringreplaceall (text,'Ë','&Euml;');
text := stringreplaceall (text,'è','&egrave;');
text := stringreplaceall (text,'È','&Egrave;');
text := stringreplaceall (text,'î','&icirc;');
text := stringreplaceall (text,'Î','&Icirc;');
text := stringreplaceall (text,'í','&iacute;');
text := stringreplaceall (text,'Í','&Iacute;');
text := stringreplaceall (text,'ì','&igrave;');
text := stringreplaceall (text,'Ì','&Igrave;');
text := stringreplaceall (text,'ï','&iuml;');
text := stringreplaceall (text,'Ï','&Iuml;');
text := stringreplaceall (text,'ñ','&ntilde;');
text := stringreplaceall (text,'Ñ','&Ntilde;');
text := stringreplaceall (text,'ö','&ouml;');
text := stringreplaceall (text,'Ö','&Ouml;');
text := stringreplaceall (text,'ò','&ograve;');
text := stringreplaceall (text,'Ò','&Ograve;');
text := stringreplaceall (text,'ó','&oacute;');
text := stringreplaceall (text,'Ó','&Oacute;');
text := stringreplaceall (text,'ø','&oslash;');
text := stringreplaceall (text,'Ø','&Oslash;');
text := stringreplaceall (text,'Ô','&Ocirc;');
text := stringreplaceall (text,'ô','&ocirc;');
text := stringreplaceall (text,'õ','&otilde;');
text := stringreplaceall (text,'Õ','&Otilde;');
text := stringreplaceall (text,'ü','&uuml;');
text := stringreplaceall (text,'Ü','&Uuml;');
text := stringreplaceall (text,'ú','&uacute;');
text := stringreplaceall (text,'Ú','&Uacute;');
text := stringreplaceall (text,'Ù','&Ugrave;');
text := stringreplaceall (text,'ù','&ugrave;');
text := stringreplaceall (text,'û','&ucirc;');
text := stringreplaceall (text,'Û','&Ucirc;');
text := stringreplaceall (text,'ý','&yacute;');
text := stringreplaceall (text,'Ý','&Yacute;');
text := stringreplaceall (text,'ÿ','&yuml;');
text := stringreplaceall (text,'|','&nbsp;');
result := text;
End;

Function sgml2win(text : String) : String;
{Funktion som ersätter alla entiteter mot deras tecken i
windows. Den färdiga strängen returneras.}
 begin
text := stringreplaceall (text,'&aacute;','á');
text := stringreplaceall (text,'&Aacute;','Á');
text := stringreplaceall (text,'&aelig;','æ');
text := stringreplaceall (text,'&Aelig;','Æ');
text := stringreplaceall (text,'&agrave;','à');
text := stringreplaceall (text,'&Agrave;','À');
text := stringreplaceall (text,'&aring;','å');
text := stringreplaceall (text,'&Aring;','Å');
text := stringreplaceall (text,'&auml;','ä');
text := stringreplaceall (text,'&Auml;','Ä');
text := stringreplaceall (text,'&Acirc;' ,'Â');
text := stringreplaceall (text,'&acirc;' ,'â');
text := stringreplaceall (text,'&atilde;','ã');
text := stringreplaceall (text,'&Atilde;','Ã');
text := stringreplaceall (text,'&ccedil;','ç');
text := stringreplaceall (text,'&Ccedil;','Ç');
text := stringreplaceall (text,'&eacute;','é');
text := stringreplaceall (text,'&Eacute;','É');
text := stringreplaceall (text,'&egrave;','è');
text := stringreplaceall (text,'&Egrave;','È');
text := stringreplaceall (text,'&ecirc;' ,'ê');
text := stringreplaceall (text,'&Ecirc;' ,'Ê');
text := stringreplaceall (text,'&euml;'  ,'ë');
text := stringreplaceall (text,'&Euml;'  ,'Ë');
text := stringreplaceall (text,'&icirc;' ,'î');
text := stringreplaceall (text,'&Icirc;' ,'Î');
text := stringreplaceall (text,'&iacute;','í');
text := stringreplaceall (text,'&Iacute;','Í');
text := stringreplaceall (text,'&igrave;','ì');
text := stringreplaceall (text,'&Igrave;','Ì');
text := stringreplaceall (text,'&iuml;'  ,'ï');
text := stringreplaceall (text,'&Iuml;'  ,'Ï');
text := stringreplaceall (text,'&ntilde;','ñ');
text := stringreplaceall (text,'&Ntilde;','Ñ');
text := stringreplaceall (text,'&ograve;','ò');
text := stringreplaceall (text,'&Ograve;','Ò');
text := stringreplaceall (text,'&oacute;','ó');
text := stringreplaceall (text,'&Oacute;','Ó');
text := stringreplaceall (text,'&ouml;','ö');
text := stringreplaceall (text,'&Ouml;','Ö');
text := stringreplaceall (text,'&oslash;','ø');
text := stringreplaceall (text,'&Oslash;','Ø');
text := stringreplaceall (text,'&Ocirc;' ,'Ô');
text := stringreplaceall (text,'&ocirc;' ,'ô');
text := stringreplaceall (text,'&otilde;','õ');
text := stringreplaceall (text,'&Otilde;','Õ');
text := stringreplaceall (text,'&uuml;','ü');
text := stringreplaceall (text,'&Uuml;','Ü');
text := stringreplaceall (text,'&uacute;','ú');
text := stringreplaceall (text,'&Uacute;','Ú');
text := stringreplaceall (text,'&ucirc;' ,'û');
text := stringreplaceall (text,'&Ucirc;' ,'Û');
text := stringreplaceall (text,'&Ugrave;','Ù');
text := stringreplaceall (text,'&ugrave;','ù');
text := stringreplaceall (text,'&yacute;','ý');
text := stringreplaceall (text,'&Yacute;','Ý');
text := stringreplaceall (text,'&yuml;'  ,'ÿ');
text := stringreplaceall (text,'&nbsp;','|');
text := stringreplaceall (text,'&amp;','&');
result := text;
End;

Function sgml2mac(text : String) : String;
{Funktion som ersätter alla entiteter mot deras tecken i
mac. Den färdiga strängen returneras.}
 begin
text := stringreplaceall (text,'&aacute;',chr(135));
text := stringreplaceall (text,'&Aacute;',chr(231));
text := stringreplaceall (text,'&aelig;',chr(190));
text := stringreplaceall (text,'&Aelig;',chr(174));
text := stringreplaceall (text,'&agrave;',chr(136));
text := stringreplaceall (text,'&Agrave;',chr(203));
text := stringreplaceall (text,'&aring;',chr(140));
text := stringreplaceall (text,'&Aring;',chr(129));
text := stringreplaceall (text,'&Auml;',chr(128));
text := stringreplaceall (text,'&auml;',chr(138));
text := stringreplaceall (text,'&Acirc;' ,chr(229));
text := stringreplaceall (text,'&acirc;' ,chr(137));
text := stringreplaceall (text,'&atilde;',chr(139));
text := stringreplaceall (text,'&Atilde;',chr(204));
text := stringreplaceall (text,'&ccedil;',chr(141));
text := stringreplaceall (text,'&Ccedil;',chr(130));
text := stringreplaceall (text,'&eacute;',chr(142));
text := stringreplaceall (text,'&Eacute;',chr(131));
text := stringreplaceall (text,'&egrave;',chr(143));
text := stringreplaceall (text,'&Egrave;',chr(233));
text := stringreplaceall (text,'&ecirc;' ,chr(144));
text := stringreplaceall (text,'&Ecirc;' ,chr(230));
text := stringreplaceall (text,'&euml;'  ,chr(145));
text := stringreplaceall (text,'&Euml;'  ,chr(232));
text := stringreplaceall (text,'&icirc;' ,chr(148));
text := stringreplaceall (text,'&Icirc;' ,chr(235));
text := stringreplaceall (text,'&iacute;' ,chr(146));
text := stringreplaceall (text,'&Iacute;' ,chr(234));
text := stringreplaceall (text,'&igrave;' ,chr(147));
text := stringreplaceall (text,'&Igrave;' ,chr(237));
text := stringreplaceall (text,'&iuml;' ,chr(149));
text := stringreplaceall (text,'&Iuml;' ,chr(236));
text := stringreplaceall (text,'&ntilde;',chr(150));
text := stringreplaceall (text,'&Ntilde;',chr(132));
text := stringreplaceall (text,'&ograve;',chr(152));
text := stringreplaceall (text,'&Ograve;',chr(241));
text := stringreplaceall (text,'&oacute;',chr(151));
text := stringreplaceall (text,'&Oacute;',chr(238));
text := stringreplaceall (text,'&Ocirc;' ,chr(239));
text := stringreplaceall (text,'&ocirc;' ,chr(153));
text := stringreplaceall (text,'&oslash;',chr(191));
text := stringreplaceall (text,'&Oslash;',chr(175));
text := stringreplaceall (text,'&otilde;',chr(155));
text := stringreplaceall (text,'&Otilde;',chr(239));
text := stringreplaceall (text,'&ouml;',chr(154));
text := stringreplaceall (text,'&Ouml;',chr(133));
text := stringreplaceall (text,'&uuml;',chr(159));
text := stringreplaceall (text,'&Uuml;',chr(134));
text := stringreplaceall (text,'&uacute;',chr(156));
text := stringreplaceall (text,'&Uacute;',chr(242));
text := stringreplaceall (text,'&ucirc;' ,chr(158));
text := stringreplaceall (text,'&Ucirc;' ,chr(243));
text := stringreplaceall (text,'&Ugrave;',chr(244));
text := stringreplaceall (text,'&ugrave;',chr(157));
text := stringreplaceall (text,'&yacute;','y');
text := stringreplaceall (text,'&yuml;'  ,chr(216));
text := stringreplaceall (text,'&Yuml;'  ,chr(217));
text := stringreplaceall (text,'&nbsp;',' ');
text := stringreplaceall (text,'&amp;',chr(38));
result := text;
End;

Function sgml2rtf(text : string) : String;
{Funktion för att byta ut sgml-entiteter mot de koder som
gäller i RTF-textrutorna.}
 begin
text := stringreplaceall (text,'}','#]#');
text := stringreplaceall (text,'{','#[#');
text := stringreplaceall (text,'\','HSALSKCAB');
text := stringreplaceall (text,'HSALSKCAB','\\');
text := stringreplaceall (text,'&aelig;','\'+chr(39)+'c6');
text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6');
text := stringreplaceall (text,'&aacute;','\'+chr(39)+'e1');
text := stringreplaceall (text,'&Aacute;','\'+chr(39)+'c1');
text := stringreplaceall (text,'&agrave;','\'+chr(39)+'e0');
text := stringreplaceall (text,'&Agrave;','\'+chr(39)+'c0');
text := stringreplaceall (text,'&aring;','\'+chr(39)+'e5');
text := stringreplaceall (text,'&Aring;','\'+chr(39)+'c5');
text := stringreplaceall (text,'&Acirc;','\'+chr(39)+'c2');
text := stringreplaceall (text,'&acirc;','\'+chr(39)+'e2');
text := stringreplaceall (text,'&atilde;','\'+chr(39)+'e3');
text := stringreplaceall (text,'&Atilde;','\'+chr(39)+'c3');
text := stringreplaceall (text,'&auml;','\'+chr(39)+'e4');
text := stringreplaceall (text,'&Auml;','\'+chr(39)+'c4');
text := stringreplaceall (text,'&ccedil;','\'+chr(39)+'e7');
text := stringreplaceall (text,'&Ccedil;','\'+chr(39)+'c7');
text := stringreplaceall (text,'&eacute;','\'+chr(39)+'e9');
text := stringreplaceall (text,'&Eacute;','\'+chr(39)+'c9');
text := stringreplaceall (text,'&egrave;','\'+chr(39)+'e8');
text := stringreplaceall (text,'&Egrave;','\'+chr(39)+'c8');
text := stringreplaceall (text,'&ecirc;','\'+chr(39)+'ea');
text := stringreplaceall (text,'&Ecirc;','\'+chr(39)+'ca');
text := stringreplaceall (text,'&euml;','\'+chr(39)+'eb');
text := stringreplaceall (text,'&Euml;','\'+chr(39)+'cb');
text := stringreplaceall (text,'&icirc;','\'+chr(39)+'ee');
text := stringreplaceall (text,'&Icirc;','\'+chr(39)+'ce');
text := stringreplaceall (text,'&iacute;','\'+chr(39)+'ed');
text := stringreplaceall (text,'&Iacute;','\'+chr(39)+'cd');
text := stringreplaceall (text,'&igrave;','\'+chr(39)+'ec');
text := stringreplaceall (text,'&Igrave;','\'+chr(39)+'cc');
text := stringreplaceall (text,'&iuml;'  ,'\'+chr(39)+'ef');
text := stringreplaceall (text,'&Iuml;'  ,'\'+chr(39)+'cf');
text := stringreplaceall (text,'&ntilde;','\'+chr(39)+'f1');
text := stringreplaceall (text,'&Ntilde;','\'+chr(39)+'d1');
text := stringreplaceall (text,'&ouml;','\'+chr(39)+'f6');
text := stringreplaceall (text,'&Ouml;','\'+chr(39)+'d6');
text := stringreplaceall (text,'&oacute;','\'+chr(39)+'f3');
text := stringreplaceall (text,'&Oacute;','\'+chr(39)+'d3');
text := stringreplaceall (text,'&ograve;','\'+chr(39)+'f2');
text := stringreplaceall (text,'&Ograve;','\'+chr(39)+'d2');
text := stringreplaceall (text,'&oslash;','\'+chr(39)+'f8');
text := stringreplaceall (text,'&Oslash;','\'+chr(39)+'d8');
text := stringreplaceall (text,'&Ocirc;','\'+chr(39)+'d4');
text := stringreplaceall (text,'&ocirc;','\'+chr(39)+'f4');
text := stringreplaceall (text,'&otilde;','\'+chr(39)+'f5');
text := stringreplaceall (text,'&Otilde;','\'+chr(39)+'d5');
text := stringreplaceall (text,'&uacute;','\'+chr(39)+'fa');
text := stringreplaceall (text,'&Uacute;','\'+chr(39)+'da');
text := stringreplaceall (text,'&ucirc;','\'+chr(39)+'fb');
text := stringreplaceall (text,'&Ucirc;','\'+chr(39)+'db');
text := stringreplaceall (text,'&Ugrave;','\'+chr(39)+'d9');
text := stringreplaceall (text,'&ugrave;','\'+chr(39)+'f9');
text := stringreplaceall (text,'&uuml;','\'+chr(39)+'fc');
text := stringreplaceall (text,'&Uuml;','\'+chr(39)+'dc');
text := stringreplaceall (text,'&yacute;','\'+chr(39)+'fd');
text := stringreplaceall (text,'&Yacute;','\'+chr(39)+'dd');
text := stringreplaceall (text,'&yuml;','\'+chr(39)+'ff');
text := stringreplaceall (text,'&#163;','\'+chr(39)+'a3');
text := stringreplaceall (text,'#]#','\}');
text := stringreplaceall (text,'#[#','\{');
text := stringreplaceall (text,'&nbsp;','|');
text := stringreplaceall (text,'&amp;','&');
result := text;
End;

function rtf2sgml (text : string) : string;
{Funktion för 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)+'c6','&aelig;');
text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;');
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)+'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)+'c2','&Acirc;');
text := stringreplaceall (text,'\'+chr(39)+'e2','&acirc;');
text := stringreplaceall (text,'\'+chr(39)+'e3','&atilde;');
text := stringreplaceall (text,'\'+chr(39)+'c3','&Atilde;');
text := stringreplaceall (text,'\'+chr(39)+'e7','&ccedil;');
text := stringreplaceall (text,'\'+chr(39)+'c7','&Ccedil;');
text := stringreplaceall (text,'\'+chr(39)+'e9','&eacute;');
text := stringreplaceall (text,'\'+chr(39)+'c9','&Eacute;');
text := stringreplaceall (text,'\'+chr(39)+'e8','&egrave;');
text := stringreplaceall (text,'\'+chr(39)+'c8','&Egrave;');
text := stringreplaceall (text,'\'+chr(39)+'ea','&ecirc;');
text := stringreplaceall (text,'\'+chr(39)+'ca','&Ecirc;');
text := stringreplaceall (text,'\'+chr(39)+'eb','&euml;');
text := stringreplaceall (text,'\'+chr(39)+'cb','&Euml;');
text := stringreplaceall (text,'\'+chr(39)+'ee','&icirc;');
text := stringreplaceall (text,'\'+chr(39)+'ce','&Icirc;');
text := stringreplaceall (text,'\'+chr(39)+'ed','&iacute;');
text := stringreplaceall (text,'\'+chr(39)+'cd','&Iacute;');
text := stringreplaceall (text,'\'+chr(39)+'ec','&igrave;');
text := stringreplaceall (text,'\'+chr(39)+'cc','&Igrave;');
text := stringreplaceall (text,'\'+chr(39)+'ef','&iuml;');
text := stringreplaceall (text,'\'+chr(39)+'cf','&Iuml;');
text := stringreplaceall (text,'\'+chr(39)+'f1','&ntilde;');
text := stringreplaceall (text,'\'+chr(39)+'d1','&Ntilde;');
text := stringreplaceall (text,'\'+chr(39)+'f3','&oacute;');
text := stringreplaceall (text,'\'+chr(39)+'d3','&Oacute;');
text := stringreplaceall (text,'\'+chr(39)+'f2','&ograve;');
text := stringreplaceall (text,'\'+chr(39)+'d2','&Ograve;');
text := stringreplaceall (text,'\'+chr(39)+'d4','&Ocirc;');
text := stringreplaceall (text,'\'+chr(39)+'f4','&ocirc;');
text := stringreplaceall (text,'\'+chr(39)+'f5','&otilde;');
text := stringreplaceall (text,'\'+chr(39)+'d5','&Otilde;');
text := stringreplaceall (text,'\'+chr(39)+'f8','&oslash;');
text := stringreplaceall (text,'\'+chr(39)+'d8','&Oslash;');
text := stringreplaceall (text,'\'+chr(39)+'f6','&ouml;');
text := stringreplaceall (text,'\'+chr(39)+'d6','&Ouml;');
text := stringreplaceall (text,'\'+chr(39)+'fc','&uuml;');
text := stringreplaceall (text,'\'+chr(39)+'dc','&Uuml;');
text := stringreplaceall (text,'\'+chr(39)+'fa','&uacute;');
text := stringreplaceall (text,'\'+chr(39)+'da','&Uacute;');
text := stringreplaceall (text,'\'+chr(39)+'fb','&ucirc;');
text := stringreplaceall (text,'\'+chr(39)+'db','&Ucirc;');
text := stringreplaceall (text,'\'+chr(39)+'d9','&Ugrave;');
text := stringreplaceall (text,'\'+chr(39)+'f9','&ugrave;');
text := stringreplaceall (text,'\'+chr(39)+'fd','&yacute;');
text := stringreplaceall (text,'\'+chr(39)+'dd','&Yacute;');
text := stringreplaceall (text,'\'+chr(39)+'ff','&yuml;');
text := stringreplaceall (text,'|','&nbsp;');
text := stringreplaceall (text,'\'+chr(39)+'a3','&#163;');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then
begin
result := '';
exit;
end;
//text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
//temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//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 därför bort
det efter \fs16 och la istället en egen tvätt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang}
 text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få }
text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika}
text := stringreplaceall (text,'\ltrpar','');
text := stringreplaceall (text,'\ql','');
text := stringreplaceall (text,'\ltrch','');
{Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu städar vi istället bort alla tvåsiffriga fontsize.}
 while pos ('\fs',text) >0 do
begin
//application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
while pos ('\f',text) >0 do
begin
//application.processmessages;
start := pos ('\f',text);
Delete(text,start,3);
end;
text := stringreplaceall (text,'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ','</P><UL>');
text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','<LI>');
text := stringreplaceall (text, '\par <LI>','<LI>');
text := stringreplaceall (text, '\par <UL>','<UL>');
text := stringreplaceall (text,'\pard\plain ','<P>');
text := stringreplaceall (text,'\par \plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
if (pos ('\par \tab ',text)>0) or (pos ('<P>\tab ',text)>0) then
begin
text := stringreplaceall (text,'\par \tab ','<TR><TD>');
text := stringreplaceall (text,'<P>\tab ','<TR><TD>');
text := stringreplaceall (text,'\tab ','</TD><TD>');
end
else
begin
text := stringreplaceall (text,'\tab ','');
end;
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
if pos('<TD>',text)>0 then text := text+'</TD></TR>';
if pos('<LI>',text)>0 then text := text+'</LI>';
result := text;
end;

end.
[000258]


sscanf в Delphi?

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

unit Scanf;

interface
uses SysUtils;

type
EFormatError = class(ExCeption);

function Sscanf(const s: string; const fmt : string;
const Pointers : array of Pointer) : Integer;
implementation

{ Sscanf выполняет синтаксический разбор входной строки. Параметры...
s - входная строка для разбора
fmt - 'C' scanf-форматоподобная строка для управления разбором
%d - преобразование в Long Integer
%f - преобразование в Extended Float
%s - преобразование в строку (ограничено пробелами)
другой символ - приращение позиции s на "другой символ"
пробел - ничего не делает
Pointers - массив указателей на присваиваемые переменные

результат - количество действительно присвоенных переменных

Например, ...
Sscanf('Name. Bill   Time. 7:32.77   Age. 8',
'. %s . %d:%f . %d', [@Name, @hrs, @min, @age]);

возвратит ...
Name = Bill  hrs = 7  min = 32.77  age = 8 }
function Sscanf(const s: string; const fmt : string;
const Pointers : array of Pointer) : Integer;
var
i,j,n,m : integer;
s1      : string;
L       : LongInt;
X       : Extended;

function GetInt : Integer;
begin
s1 := '';
while (s[n] = ' ')  and (Length(s) > n) do inc(n);
while (s[n] in ['0'..'9', '+', '-'])
and (Length(s) >= n) do begin
s1 := s1+s[n];
inc(n);
end;
Result := Length(s1);
end;

function GetFloat : Integer;
begin
s1 := '';
while (s[n] = ' ')  and (Length(s) > n) do inc(n);
while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E'])
and (Length(s) >= n) do begin
s1 := s1+s[n];
inc(n);
end;
Result := Length(s1);
end;

function GetString : Integer;
begin
s1 := '';
while (s[n] = ' ')  and (Length(s) > n) do inc(n);
while (s[n] <> ' ') and (Length(s) >= n) do
begin
s1 := s1+s[n];
inc(n);
end;
Result := Length(s1);
end;

function ScanStr(c : Char) : Boolean;
begin
while (s[n] <> c) and (Length(s) > n) do inc(n);
inc(n);

If (n <= Length(s)) then Result := True
else Result := False;
end;

function GetFmt : Integer;
begin
Result := -1;

while (TRUE) do begin
while (fmt[m] = ' ') and (Length(fmt) > m) do inc(m);
if (m >= Length(fmt)) then break;

if (fmt[m] = '%') then begin
inc(m);
case fmt[m] of
'd': Result := vtInteger;
'f': Result := vtExtended;
's': Result := vtString;
end;
inc(m);
break;
end;

if (ScanStr(fmt[m]) = False) then break;
inc(m);
end;
end;

begin
n := 1;
m := 1;
Result := 0;

for i := 0 to High(Pointers) do begin
j := GetFmt;

case j of
vtInteger : begin
if GetInt > 0 then begin
L := StrToInt(s1);
Move(L, Pointers[i]^, SizeOf(LongInt));
inc(Result);
end
else break;
end;

vtExtended : begin
if GetFloat > 0 then begin
X := StrToFloat(s1);
Move(X, Pointers[i]^, SizeOf(Extended));
inc(Result);
end
else break;
end;

vtString : begin
if GetString > 0 then begin
Move(s1, Pointers[i]^, Length(s1)+1);
inc(Result);
end
else break;
end;

else break;
end;
end;
end;

end.
[000301]


Преобразования типа Comp в тип Str

Были какие-то разговоры о том, что тип 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 - беззнаковое двойное слово. Я действительно не знаю, почему Delphi и Object Pascal рассматривают 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.

-Neil Rubenkind [000635]


Перекодировка текста

Публикую присланное читателем письмо:

Недавно меня озадачили. Попросили написать программу которая переводит текст из кодировки Dos в Windows и наоборот. Я немного покопался в help'е и вот что у меня получилось. Я надеюсь вас заинтересует мое решение.

procedure MyOemToChar;
var  b:string;
begin
b:=Memo1.Lines.Text;
OemToChar(PChar(b),Pchar(b));
Memo2.Lines.Text:=b;
end;

или

procedure MyOemToChar;
var  b:PChar;
begin
b:=Memo1.Lines.GetText;
OemToChar(b,b);
Memo2.Lines.Text:=StrPas(b);
end;

Я сам предпочитаю использовать вариант N1. Хотя во время тестирования оба варианта работали.

Всего наилучшего. Виталий Еремеев. [000703]


Действительно БЫСТРОЕ преобразование сигнала в спекр и обратно (методы Хартли, Фурье и классический)

Публикую присланный читателем алгоритм:

{$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]


Цвет строкой

В модуле graphics имеются две недокументированные функции:

function ColorToString(Color: TColor): string;

Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.

function StringToColor(S: string): TColor;

Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.

- Scott Samet [000858]


Преобразование в EBCDIC

Сам алгоритм преобразования очень прост...

Const
a2e : array [0..255] of byte =
(000,001,002,003,055,045,046,047,022,005,037,011,012,013,014,159,
016,017,018,019,182,181,050,038,024,025,063,039,028,029,030,031,
064,090,127,123,091,108,080,125,077,093,092,078,107,096,075,097,
240,241,242,243,244,245,246,247,248,249,122,094,076,126,110,111,
124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
215,216,217,226,227,228,229,230,231,232,233,173,224,189,095,109,
121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
151,152,153,162,163,164,165,166,167,168,169,192,106,208,161,007,
104,220,081,066,067,068,071,072,082,083,084,087,086,088,099,103,
113,156,158,203,204,205,219,221,224,236,252,176,177,178,062,180,
069,085,206,222,073,105,154,155,171,015,186,184,183,170,138,139,
060,061,098,079,100,101,102,032,033,034,112,035,114,115,116,190,
118,119,120,128,036,021,140,141,142,065,006,023,040,041,157,042,
043,044,009,010,172,074,174,175,027,048,049,250,026,051,052,053,
054,089,008,056,188,057,160,191,202,058,254,059,004,207,218,020,
225,143,070,117,253,235,238,237,144,239,179,251,185,234,187,255);

Procedure StringA2E(var StringToConvert:String);
Var     Loop:Integer;
begin
For Loop := 1 to length(StringToConvert) do
StringToConvert[Loop] := a2e[ord(StringToConvert[Loop])];
end;

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

- Matthew Augier [000866]


Одной строкой

Преобразование String в Pchar

Тарасов Николай Валентинович советует:

function strtoPchar(s:string):Pchar;
begin
S := S+#0;
result:=StrPCopy(@S[1], S) ;
end;

Алексей Варламов добавляет:

Преобразование String в Pchar:

pch:=PChar(str); //Delphi 3+

обратно:

str:=String(pch);

[000884]


Вычисление даты Пасхи

function TtheCalendar.CalcEaster:String;
var B,D,E,Q:Integer;
GF:String;
begin
B:=225-11*(Year Mod 19);
D:=((B-21)Mod 30)+21;
If D>48 then Dec(D);
E:=(Year+(Year Div 4)+D+1)Mod 7;
Q:=D+7-E;
If Q<32 then begin
If ShortDateFormat[1]='d' then
Result:=IntToStr(Q)+'/3/'+IntToStr(Year)
else Result:='3/'+IntToStr(Q)+'/'+IntToStr(Year);
end
else begin
If ShortDateFormat[1]='d' then
Result:=IntToStr(Q-31)+'/4/'+IntToStr(Year)
else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);
end;
{вычисление страстной пятницы}
If Q<32 then begin
If ShortDateFormat[1]='d' then GF:=IntToStr(Q-2)+'/3/'+IntToStr(Year)
else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year);
end
else begin
If ShortDateFormat[1]='d' then
GF:=IntToStr(Q-31-2)+'/4/'+IntToStr(Year)
else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year);
end;

end;
[000009]


Дни недели

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

Моя функция как раз этим и занимается.

unit datefunc;

interface
function checkdate (date : string) :boolean;
function Date2julian (date : string) : longint;
function Julian2date (julian : longint) : string;
function DayOfTheWeek (date : string) :string;
function idag : string;

implementation
uses
sysutils;

function idag () : string;
{Получает текущую дату и возвращает ее в формате YYYYMMDD для использования
другими функциями данного молуля.}
var
Year, Month, Day: Word;
begin
DecodeDate(Now, Year, Month, Day);
result := IntToStr(year)+ IntToStr(Month) +IntToStr(day);
end;

function Date2julian (date : string) : longint;
{Получает дату в формате YYYYMMDD.
Если у вас другой формат,
в первую очередь преобразуйте его.}
var
month,day,year:integer;
ta,tb,tc : longint;
begin
month := strtoint(copy(date,5,2));
day := strtoint(copy(date,7,2));
year := strtoint(copy(date,1,4));
if month > 2 then
month := month - 3
else
begin
month := month + 9;
year := year - 1;
end;
ta := 146097 * (year div 100) div 4;
tb := 1461 * (year MOD 100) div 4;
tc := (153 * month + 2) div 5 + day + 1721119;
result := ta + tb + tc
end;

function mdy2date (month, day, year : integer) : string;
var
y,m,d : string;
begin
y := '000'+inttostr(year);
y := copy(y,length(y)-3,4);
m := '0'+inttostr(month);
m := copy(m,length(m)-1,2);
d := '0'+inttostr(day);
d := copy(d,length(d)-1,2);
result := y+m+d;

end;

function Julian2date (julian : longint) : string;
{Получает значение и возвращает дату в формате YYYYMMDD}
var
x,y,d,m : longint;
month,day,year : integer;
begin
x := 4 * julian - 6884477;
y := (x div 146097) * 100;
d := (x MOD 146097) div 4;
x := 4 * d + 3;
y := (x div 1461) + y;
d := (x MOD 1461) div 4 + 1;
x := 5 * d - 3;
m := x div 153 + 1;
d := (x MOD 153) div 5 + 1;
if m < 11 then
month := m + 2
else
month := m - 10;
day := d;
year := y + m div 11;
result := mdy2date(month, day, year);
end;

function checkdate (date : string) :boolean;
{Дата должна быть в формате YYYYMMDD.}
var
julian : longint;
test : string;
begin
{Сначала преобразовываем строку в юлианский формат даты.
Это позволит получить необходимое значение.}
julian := Date2julian(date);
{Затем преобразовываем полученную величину в дату.
Это всегда будет правильной датой. Для проверки делаем обратное преобразование.
Результат проверки передаем как выходной параметр функции.}
test := Julian2date(julian);

if date = test then
result := true
else
result := false;
end;

function DayOfTheWeek (date : string) :string;
{Получаем дату в формате YYYYMMDD
и возвращаем день недели.}
var
julian : longint;
begin
julian := (Date2julian(date)) MOD 7;
case julian of
0 : result := 'Понедельник';
1 : result := 'Вторник';
2 : result := 'Среда';
3 : result := 'Четверг';
4 : result := 'Пятница';
5 : result := 'Суббота';
6 : result := 'Воскресенье';
end;
end;

end.

Тем не менее, начиная со второй версии, Delphi содержат в своем арсенале замечательную функцию DayOfWeek, возвращающую целочисленный результат в диапазоне от 1 до 7. Вот пример кода, присланный Андреем Ивановым (lynxhome@mail.ru):

uses SysUtils, ...
......
function TForm1.DayOfWeekRus(S:TDateTime): string;
begin
case DayOfWeek(S) of
1:   Result:='Воскресенье';
2:   Result:='Понедельник';
3:   Result:='Вторник';
4:   Result:='Среда';
5:   Result:='Четверг';
6:   Result:='Пятница';
7:   Result:='Суббота';
end;
end;

Сергей AKA WildSery дополняет:

В самом Delphi есть такая функция, как FormatDateTime('yyyyddmm',Date), к тому же она еще много чего умеет. [000010]


Формат даты

У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.

Некоторое время назад я делал простой шифратор/дешифратор дат, проверяющий достоверность даты. Код приведен ниже.

function CheckDateFormat(SDate:string):string;
var
IDateChar:string;
x,y:integer;
begin
IDateChar:='.,\/';
for y:=1 to length(IDateChar) do
begin
x:=pos(IDateChar[y],SDate);
while x>0 do
begin
Delete(SDate,x,1);
Insert('-',SDate,x);
x:=pos(IDateChar[y],SDate);
end;
end;
CheckDateFormat:=SDate;
end;

function DateEncode(SDate:string):longint;
var
year,month,day:longint;
wy,wm,wd:longint;
Dummy:TDateTime;
Check:integer;
begin
DateEncode:=-1;
SDate:=CheckDateFormat(SDate);
Val(Copy(SDate,1,pos('-',SDate)-1),day,check);
Delete(Sdate,1,pos('-',SDate));
Val(Copy(SDate,1,pos('-',SDate)-1),month,check);
Delete(SDate,1,pos('-',SDate));
Val(SDate,year,check);
wy:=year;
wm:=month;
wd:=day;
try
Dummy:=EncodeDate(wy,wm,wd);
except
year:=0;
month:=0;
day:=0;
end;
DateEncode:=(year*10000)+(month*100)+day;
end;
[000011]


Функция DateSer

Привет, я хочу в качестве совета поделиться функцией DateSer, которую я написал перед этим на VB. Данная функция весьма полезна но, к сожалению, ее нет в Delphi. Применяется она так:

DecodeDate(Date,y,m,d);
NewDate:=DateSer(y-4,m+254,d+1234);

или приблизительно так....

function DateSer(y,m,d: Integer): TDateTime;
const
mj: array[1..12] of Integer=(31,28,31,30,31,30,31,31,30,31,30,31);
var
add: Integer;
begin
while(true) do begin
y:=y+(m-1) div 12;
m:= (m-1) mod 12 +1;
if m<=0 then begin
Inc(m,12);
Dec(y);
end;
if  ((y mod 4 = 0) and
((y mod 100<>0) or (y mod 400=0)))
and (m=2) then
add:=1 //дополнительный день в феврале
else
add:=0;
if (d>0) and (d<=(mj[m]+add)) then break;
if d>0 then begin Dec(d,mj[m]+add); Inc(m); end
else begin Inc(d,mj[m]+add); Dec(m); end;
end;
Result:=EncodeDate(y,m,d);
end;
[000012]


Математика времени

Работа с временными величинами в Delphi очень проста, если пользоваться встроенными функциями преобразования. Определите глобальные Hour, Minute, Second и инициализируйте их следующим образом:

Hour   := EncodeTime(1,0,0,0);
Minute := EncodeTime(0,1,0,0);
Second := EncodeTime(0,0,1,0);

Или, если вы предпочитаете константы, сделайте так:

Hour = 3600000/MSecsPerDay;
Minute = 60000/MSecsPerDay;
Second = 1000/MSecsPerDay;

Теперь для того, чтобы добавить 240 минут к переменной TDateTime, просто сделайте

T := T + 240*Minute;

[000467]


Delphi 1

Проверка дат

function ValidDate(const S : String) : Boolean;
BEGIN
Result := True;
try
StrToDate(S);
except
ON EConvertError DO Result := False;
end;
END

[000556]


Delphi 1

Организация цикла между двумя датами

TDateTime - вещественное число (дата размещается в левой части числа, до десятичной точки, время - в правой части).

Для организации цикла от StartDate до StopDate, просто напишите from trunc(StartDate) to trunc(StopDate). [000574]


Одной строкой

Получение номера месяца по его имени

...через цикл обхода элементов глобального массива LongMonthNames:

Function GetMonthNumber ( Month : String ) : Integer;
Begin
For Result := 1 to 12 do
If Month = LongMonthNames[Result] Then Exit;
Result := 0;
End;

[000646]


Универсальная функция возврата значения элемента даты

Галимарзанов Фанис советует:

Универсальная функция возврата значения элемента даты (год, месяц, день, квартал):

function RetDate(inDate:TDateTime;inTip:integer):integer; var xYear,xMonth,xDay:word;
begin
Result:=0;
DecodeDate(inDate,xYear,xMonth,xDay);
case inTip of
1: Result:=xYear;                  // год
2: Result:=xMonth;                 // месяц
3: Result:=xDay;                   // день
4: if xMonth<4 then Result:=1 else // квартал
if xMonth<7 then Result:=2 else
if xMonth<10 then Result:=3 else Result:=4;
end;
end;

[000795]


Delphi 1

Частичный показ DateTime

При отображении TDateTimeField в DBGrid с форматированием hh:mm (для показа только времени), любая попытка изменения времени приводит (при передаче данных) к ошибке примерно такого содержания: "'07:00 is not a valid DateTime" (07:00 - неверный DateTime). Я хотел бы посылать данные приблизительно в таком виде "trunc(oldDateTimevalue)+strtoTime(displaytext)"

Следующий обработчик события TDateTimeField OnSetText не слишком элегантен, но он работает!

procedure TForm1.Table1Date1SetText(Sender: TField; const Text: String);
var
d: TDateTime;
t: string;
begin
t := Text;
with Sender as TDateTimeField do begin
if IsNull then d := SysUtils.Date
else d := AsDateTime;
AsDateTime := StrToDateTime(Copy(DateToStr(d),1,8)+' '+t);
end;
end;

Здесь мы исходим из предположения, что у вас имеется маска редактирования, допускающая формат hh:mm или hh:mm:ss.

- Mike Orriss [000868]


Delphi 2

Внимание! TDateTime 1899

Для обратной сортировки во многих моих таблицах я использую инвертирование поля типа дата (12/31/9999 минус реальная дата).

В первой версии Delphi все было нормально, но во второй это не сработало, зато вот что я обнаружил в на странице 135 Reference Library Guide:

Delphi 1.0 вычислял дату первого года с 1899. Для преобразования даты Delphi 1.0 в формат даты Delphi 2.0, необходимо вычесть 693594.0 из даты Delphi 1.0. Формат даты был изменен для обеспечения совместимости с OLE 2.0 Automation.

- Kenneth D. James [000904]


64-битное кодирование/декодирование I

Привожу нетестированный код. Автор: Arne de Bruijn.

{ 64-битное декодирование файлов }
{ Arne de Bruijn }
uses dos;
var
Base64:array[43..122] of byte;
var
T:text;
Chars:set of char;
S:string;
K,I,J:word;
Buf:pointer;
DShift:integer;
F:file;
B,B1:byte;
Decode:array[0..63] of byte;
Shift2:byte;
Size,W:word;
begin
FillChar(Base64,SizeOf(Base64),255);
J:=0;
for I:=65 to 90 do
begin
Base64[I]:=J;
Inc(J);
end;
for I:=97 to 122 do
begin
Base64[I]:=J;
Inc(J);
end;
for I:=48 to 57 do
begin
Base64[I]:=J;
Inc(J);
end;
Base64[43]:=J; Inc(J);
Base64[47]:=J; Inc(J);
if ParamCount=0 then
begin
WriteLn('UNBASE64 <mime-файл> [<выходной файл>]');
Halt(1);
end;
S:=ParamStr(1);
assign(T,S);
GetMem(Buf,32768);
SetTextBuf(T,Buf^,32768);
{$I-} reset(T); {$I+}
if IOResult<>0 then
begin
WriteLn('Ошибка считывания ',S);
Halt(1);
end;
if ParamCount>=2 then
S:=ParamStr(2)
else
begin write('Расположение:'); ReadLn(S); end;
assign(F,S);
{$I-} rewrite(F,1); {$I+}
if IOResult<>0 then
begin
WriteLn('Ошибка создания ',S);
Halt(1);
end;
while not eof(T) do
begin
ReadLn(T,S);
if (S<>'') and (pos(' ',S)=0) and (S[1]>=#43) and (S[1]<=#122) and
(Base64[byte(S[1])]<>255) then
begin
FillChar(Decode,SizeOf(Decode),0);
DShift:=0;
J:=0; Shift2:=1;
Size:=255;
B:=0;
for I:=1 to Length(S) do
begin
case S[I] of
#43..#122:B1:=Base64[Ord(S[I])];
else
B1:=255;
end;
if B1=255 then
if S[I]='=' then
begin
B1:=0; if Size=255 then Size:=J;
end
else
WriteLn('Ошибка символа:',S[I],' (',Ord(S[I]),')');
if DShift and 7=0 then
begin
Decode[J]:=byte(B1 shl 2);
DShift:=2;
end
else
begin
Decode[J]:=Decode[J] or Hi(word(B1) shl (DShift+2));
Decode[J+1]:=Lo(word(B1) shl (DShift+2));
Inc(J);
Inc(DShift,2);
end;
end;
if Size=255 then Size:=J;
BlockWrite(F,Decode,Size);
end;
end;
Close(F);
close(T);
end.
[000074]


64-битное кодирование/декодирование II

Пришло от читателя письмо:

Хочу предложить еще одну реализацию алгоритма декодирования base64. Код проверен, работает без глюков. Евгений.

С удовольствием публикую данный код:

Const
Base64Table='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Decode(cStr:string):string;
var ResStr:string;
DecStr:string;
RecodeLine   : array [1..76] of byte;
f1,f2 : word;
l:integer;
begin
l :=length(cStr);
ResStr:='';
for f1:=1 to l do
if cStr[f1]='=' then RecodeLine[f1]:=0
else RecodeLine[f1]:=pos(cStr[f1],Base64Table)-1;
f1:=1;
while f1<length(cStr) do
begin
DecStr:=chr(byte(RecodeLine[f1]   shl 2)+RecodeLine[f1+1] shr 4)+
chr(byte(RecodeLine[f1+1] shl 4)+RecodeLine[f1+2] shr 2)+
chr(byte(RecodeLine[f1+2] shl 6)+RecodeLine[f1+3]);
ResStr:=ResStr+DecStr;
inc(f1,4);
end;
Base64Decode:=ResStr;
end;
[000782]


Проверка кредитной карты

unit Creditc;

{*****************************************************************************

Модуль Delphi для проверки номера кредитной карты

Версия: 1.1
Дата: Декабрь 20, 1996

Данный модуль создан на основе алгоритма ccard автора Peter Miller.
Автор не против бесплатного использования, но резервирует все права
на данный алгоритм.

авторское право 1996 Shawn Wilson Harvell ( shawn@inet.net )

применение:

Внесите данный модуль в список uses любого модуля, которому
необходим доступ к функции проверки кредитной карты.

IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean

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

CardNumber - строка, содержащая номер карты, которую необходимо проверить
ReturnMessage - строка, с помощью которой функция может возвратить любое сообщение
( при этом старое содержимое строки стирается )

возвращает true если номер карточки верен, false - в противном случае.

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

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

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

На момент написания модуля он устойчиво работал под Delphi версий 1 и 2,
для Turbo Pascal необходимо внести некоторые несложные исправления (главным
образом из-за различия реализации функций в модуле SysUtils).

Если вы нашли этот модуль полезным, имеете какие-то пожелания или предложения,
отправьте автору письмо по адресу электронной почты shawn@inet.net

История изменений

версия 1.1 -- Декабрь 20, 1996
исправлена ошибка с Discover card: соответственно увеличина длина маски "database"

версия 1.0 -- Октябрь 26, 1996
первый выпуск

*****************************************************************************}

interface

uses SysUtils;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;

implementation

const
CardPrefixes: array[ 1..19 ] of string  =
( '2014', '2149', '300', '301', '302',
'303', '304', '305', '34', '36', '37',
'38', '4', '51', '52', '53', '54', '55', '6011' );

CardTypes: array[ 1..19 ] of String =
( 'enRoute',
'enRoute',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'Diner Club/Carte Blanche',
'American Express',
'Diner Club/Carte Blanche',
'American Express',
'Diner Club/Carte Blanche',
'Visa',
'MasterCard',
'MasterCard',
'MasterCard',
'MasterCard',
'MasterCard',
'Discover' );

function RemoveChar(const Input: String; DeletedChar: Char): String;
var
Index: Word;                    { переменная счетчика                           }
begin
{ данная функция удаляет все вхождения указанного символа из переданной ей      }
{ строки                                                                        }
Result := Input;
for Index := Length( Result ) downto 1 do
if Result[ Index ] = DeletedChar then Delete( Result, Index, 1 );
end;

function ShiftMask( Input: Integer ): Integer;
begin
{ простая оболочка для функции сдвига битов числа                              }
result := ( 1 shl ( Input - 12 ) );
end;

function ConfirmChecksum( CardNumber: String ): Boolean;
var
CheckSum: Integer;             { Содержит значение операции                    }
Flag: Boolean;                 { флаг готовности                               }
Counter: Integer;              { индекс счетчика                               }
PartNumber: String;            { используется для извлечения каждой цифры числа}
Number: Integer;               { исп-ся для преобразования каждой цифры в число}
begin

{**************************************************************************
Это, вероятно, самая запутанный код, который вы когда-либо видели, я и сам
запутался, когда работал над ним. Основное, что делает данная функция -
извлекает каждую цифру из номера карты для использования в формуле проверки
контрольной суммы, устанавливаемую компаниями. Алгоритм производит выборку,
начиная от последней цифры и заканчивая первой.
**************************************************************************}
{ получаем стартовое значение счетчика }
Counter := Length( CardNumber  );
CheckSum := 0;
PartNumber := '';
Number := 0;
Flag := false;

while ( Counter >= 1 ) do
begin
{ получаем текущую цифру }
PartNumber := Copy( CardNumber, Counter, 1 );
Number := StrToInt( PartNumber ); { преобразуем в число }
if ( Flag ) then { только каждую вторую цифру }
begin
Number := Number * 2;
if ( Number >= 10 ) then Number := Number - 9;
end;
CheckSum := CheckSum + Number;

Flag := not( Flag );

Counter := Counter - 1;
end;

result := ( ( CheckSum mod 10 ) = 0 );
end;

function GetMask( CardName: String  ): Integer;
begin
{ значение по умолчанию }
result := 0;

if ( CardName = 'MasterCard' ) then result := ShiftMask( 16 );
if ( CardName = 'Visa' ) then result := ( ShiftMask( 13 ) or ShiftMask( 16 ) );
if ( CardName = 'American Express' ) then result := ShiftMask( 15 );
if ( CardName = 'Diner Club/Carte Blanche' ) then result := ShiftMask( 14 );
if ( CardName = 'Discover' ) then result := ShiftMask( 16 );

end;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;
var
StrippedNumber: String;        { используется для хранения числа без дополнительных символов }
Index: Integer;                { универсальный счетчик для циклов и т.п.                     }
TheMask: Integer;              { число, которое мы будем использовать для маски              }
FoundIt: Boolean;              { используется для индикации, когда что-либо найдено          }
CardName: String;              { хранит имя типа карты                                       }
PerformChecksum: Boolean;      { тип enRoute карты если контрольная сумма не сошлась         }
begin

{ сначала избавимся от пробелов и тире }
StrippedNumber := RemoveChar( CardNumber, ' ' );
StrippedNumber := RemoveChar( StrippedNumber, '-' );

{ если строка была нулевой длины, то тоже OK }
if ( StrippedNumber = '' ) then
begin
result := true;
exit;
end;

{ инициализация возвращаемых переменных }
MessageText := '';
result := true;

{ устанавливаем нашу переменную-флаг }
FoundIt := false;

{ проверка правильности введенных символов в номере карты }
for Index := 1 to Length( StrippedNumber ) do
begin
case StrippedNumber[ Index ] of
'0'..'9': FoundIt := FoundIt;   { другими словами не op }
else
MessageText := 'Неверный введенный символ';
result := false;
exit;
end;
end;

{ теперь давайте определим тип используемой карты }
for Index := 1 to 19 do
begin
if ( Pos( CardPrefixes[ Index ], StrippedNumber ) = 1 ) then
begin
{ мы обнаружили правильный тип }
FoundIt := true;
CardName := CardTypes[ Index ];
TheMask := GetMask( CardName );
end;
end;

{ если тип карты не определен, указываем на это }
if ( not FoundIt ) then
begin
CardName := 'Unknown Card Type';
TheMask := 0;
MessageText := 'Неизвестный тип карты ';
result := false;
exit;
end;

{ проверка длины }
if ( ( Length( StrippedNumber ) > 28 ) and result ) then
begin
MessageText := 'Номер слишком большой ';
result := false;
exit;
end;

{ проверка длины }
if ( ( Length( StrippedNumber ) < 12 ) or
( ( shiftmask( length( strippednumber ) ) and themask ) = 0 ) ) then
begin
messagetext := 'неверная длина числа';
result := false;
exit;
end;

{ проверяем вычисление контрольной суммы }
if ( cardname = 'enroute' ) then
performchecksum := false
else
performchecksum := true;

if ( performchecksum and ( not confirmchecksum( strippednumber ) ) ) then
begin
messagetext := 'неверная контрольная сумма';
result := false;
exit;
end;

{ если результат равен true, тогда все ok }
if ( result ) then
messagetext := 'номер верен: тип карты: ' + cardname;

{ если строка была нулевой длины, то тоже OK }
if ( strippednumber = '' ) then
result := true;

end;

end.

[000304]


Delphi 1

Кодирование/декодирование строки

Как закодировать строку?

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

{ Начало кода }

program Crypt;

uses WinCRT;

const
C1 = 52845;
C2 = 22719;

function Encrypt(const S: String; Key: Word): String;
var
I: byte;
begin
Result[0] := S[0];
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * C1 + C2;
end;
end;

function Decrypt(const S: String; Key: Word): String;
var
I: byte;
begin
Result[0] := S[0];
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(S[I]) + Key) * C1 + C2;
end;
end;

var
S: string;
begin
Write('>');
ReadLn(S);
S := Encrypt(S,12345);
WriteLn(S);
S := Decrypt(S,12345);
WriteLn(S);
end.

[000675]


Delphi 2

FFT аглоритм для Delphi 2

Привожу 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.

[000111]


32-битный CRC

Приведен модуль для Delphi 1.0 (для Delphi 2.0 должны быть сделаны небольшие изменения):

UNIT CRC32;

{CRC32 рассчитывает код циклической избыточности (cyclic redundancy code - CRC),
известный как CRC-32, с использованием алгоритма byte-wise ("мудрый байт").

(C) Авторские права 1989, 1995-1996 Earl F. Glynn, Overland Park, KS.
Все права защищены.

Данный модуль является производным от программы CRCT FORTRAN 77, опубликованной
в "Byte-wise CRC Calculations" за авторством Aram Perez из IEEE Micro, Июнь 1983,
страницы 40-50. Константы для полиномиального генератора CRC-32, приведенные
здесь, опубликованы в "Microsoft Systems Journal", Март 1995, страницы 107-108.

Данный CRC алгоритм имеет бОльшую скорость за счет 512 элементов таблицы
поиска.}

INTERFACE

PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt);
PROCEDURE CalcFileCRC32 (FromName: STRING; VAR CRCvalue: LongInt;
VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt;
VAR error:  WORD);

IMPLEMENTATION

CONST
table:  ARRAY[0..255] OF LongInt =
($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
buffer = ARRAY[1..65521] OF BYTE;  { самый большой буфер, который     }
{ только можно распределить в Куче }
VAR
i:  WORD;
q:  ^buffer;

PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt);
{Ниже выполняется небольшое криптование (но выполняется очень быстро).
Алгоритм работает следующим образом:
1.  совершаем операцию "И/ИЛИ" (XOR) входного байта с младшей
частью регистра CRC для получения INDEX
2.  сдвигаем регистр CRC на восемь битов вправо
3.  совершаем операцию "И/ИЛИ" (XOR) с CRC регистром и
Table[INDEX]
4.  повторяем шаги с 1 по 3 для всех байтов }
BEGIN
q := p;
FOR   i := 1 TO nBYTE DO
CRCvalue := (CRCvalue SHR 8)  XOR
Table[ q^[i] XOR (CRCvalue AND $000000FF) ]
END {CalcCRC32};

PROCEDURE CalcFileCRC32 (FromName:  STRING; VAR CRCvalue:  LongInt;
VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt;
VAR error:  WORD);
VAR
BytesRead:  WORD;
FromFile :  FILE;
i        :  WORD;
BEGIN
FileMode := 0;  {Turbo по умолчанию 2 для R/W и 0 для R/O}
CRCValue := $FFFFFFFF;
ASSIGN (FromFile,FromName);
{$I-} RESET (FromFile,1); {$I+}
error := IOResult;
IF   error = 0
THEN BEGIN
TotalBytes := 0;
REPEAT
BlockRead (FromFile,IOBuffer^,BufferSize,BytesRead);
CalcCRC32 (IOBuffer,BytesRead,CRCvalue);
INC (TotalBytes, BytesRead)
UNTIL BytesRead = 0;
CLOSE (FromFile)
END;
CRCvalue := NOT CRCvalue
END {CalcFileCRC32};

END {CRC}.

[000156]


Возведение числа в степень I

В: Это может звучать тривиально, но как мне возвести число в степень? Например, 2^12 = 4095.

На самом деле вопрос далеко не тривиальный. Проблема в том, что сам алгоритм функции далеко не прост. Функцией Power(X, N) (т.е. X^N) должны четко отслеживаться несколько возможных ситуаций:

  1. X любое число, N = 0
  2. X = 1, N любое число
  3. X = 0 и N > 0
  4. X = 0 и N < 0
  5. X > 0
  6. X < 0 и N нечетное целое
  7. X < 0 и N целое
  8. X < 0 и N нецелое
Посмотрите на следующую, абсолютно правильно работающую функцию (тем не менее она может быть и не самой эффективной!):

interface

type
EPowerException = class(Exception)
end;

implementation

function Power(X, N : real) : extended; var
t : longint;
r : real;
isInteger : boolean;
begin

if N = 0 then begin
result := 1.0;
exit;
end;

if X = 1.0 then begin
result := 1.0;
exit;
end;

if X = 0.0 then begin
if N > 0.0 then
begin
result := 0.0;
exit;
end
else
raise EPowerException.Create('Результат - бесконечность');
end;

if (X > 0) then
try
result := exp(N * ln(X));
exit;
except
raise EPowerException.Create('Результат - переполнение или потеря значимости');
end;

{ X - отрицательный, но мы все еще можем вычислить результат, если n целое. }
{ пытаемся получить целую часть n с использованием типа longint, вычисление }
{ четности n не займет много времени }
try
t := trunc(n);
if (n - t) = 0 then
isInteger := true
else
isInteger := False;
except
{ Лишний бит может вызвать переполнение или потерю значимости }
r := int(n);
if (n - r) = 0 then
begin
isInteger := true;
if frac(r/2) = 0.5 then
t := 1
else
t := 2;
end
else
isInteger := False;
end;

if isInteger then
begin
{n целое}
if odd(t) then
{n нечетное}
try
result := -exp(N * ln(-X));
exit;
except
raise EPowerException.Create('Результат - переполнение или потеря значимости');
end
else
{n четное}
try
result := exp(N * ln(-X));
exit;
except
raise EPowerException.Create('Результат - переполнение или потеря значимости');
end;
end
else
raise EPowerException.Create('Результат невычисляем');

end;

[000157]


Одной строкой

Возведение числа в степень II

X^Y = exp(ln(X) * Y) c некоторыми условиями (например, X не может быть нулем). [000495]


Вычислитель математических формул

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

FORMULA должна быть стокой, содержащей формулу. Допускаются переменные x, y и z, а также операторы, перечисленные ниже. Пример:

sin(x)*cos(x^y)+exp(cos(x))

Использование:

uses EVALCOMP;

var calc:    EVALVEC ; (evalvec - указатель на объект, определяемый evalcomp)
FORMULA: string;

begin

FORMULA:='x+y+z';

new (calc,init(FORMULA)); (Построение дерева оценки)

writeln ( calc^.eval1d(7) )     ; (x=7 y=0 z=0; result:  7)
writeln ( calc^.eval2d(7,8) )   ; (x=7 y=8 z=0; result: 15)
writeln ( calc^.eval3d(7,8,9) ) ; (x=7 y=8 z=9; result: 24)

dispose(calc,done); (разрушение дерева оценки)

end.

Допустимые операторы:

x <l;> y ; Логические операторы возвращают 1 в случае истины и 0 если ложь.
x <l;= y
x >= y
x > y
x <l; y
x = y
x + y
x - y
x eor y ( исключающее или )
x or y
x * y
x / y
x and y
x mod y
x div y
x ^ y ( степень )
x shl y
x shr y
not (x)
sinc (x)
sinh (x)
cosh (x)
tanh (x)
coth (x)
sin (x)
cos (x)
tan (x)
cot (x)
sqrt (x)
sqr (x)
arcsinh (x)
arccosh (x)
arctanh (x)
arccoth (x)
arcsin (x)
arccos (x)
arctan (x)
arccot (x)
heavy (x) ; 1 для положительных чисел, 0 для остальных
sgn (x) ; 1 для положительных чисел, -1 для отрицательных и 0 для нуля
frac (x)
exp (x)
abs (x)
trunc (x)
ln (x)
odd (x)
pred (x)
succ (x)
round (x)
int (x)
fac (x) ; x*(x-1)*(x-2)*...*3*2*1
rnd ; Случайное число в диапазоне [0,1]
rnd (x) ; Случайное число в диапазоне [0,x]
pi
e

unit evalcomp;

interface

type fun= function(x,y:real):real;
evalvec= ^evalobj;
evalobj= object
f1,f2:evalvec;
f1x,f2y:real;
f3:fun;
function eval:real;
function eval1d(x:real):real;
function eval2d(x,y:real):real;
function eval3d(x,y,z:real):real;
constructor init(st:string);
destructor done;
end;
var  evalx,evaly,evalz:real;

implementation

var analysetmp:fun;

function search (text,code:string; var pos:integer):boolean;
var i,count:integer;
flag:boolean;
newtext:string;
begin
if length(text)<l;length(code) then begin search:=false; exit; end;
flag:=false;
pos:=length(text)-length(code)+1;
repeat
if code=copy(text,pos,length(code))
then flag:=true
else dec(pos);
if flag
then
begin
count:=0;
for i:= pos+1 to length(text) do
begin
if copy(text,i,1) = '(' then inc(count);
if copy(text,i,1) = ')' then dec(count);
end;
if count<l;>0
then
begin
dec(pos);
flag:=false;
end;
end;
until (flag=true) or (pos=0);
search:=flag;
end;

function myid(x,y:real):real;
begin
myid:=x;
end;

function myunequal(x,y:real):real;
begin
if x<>y then
myunequal:=1
else
myunequal:=0;
end;

function mylessequal(x,y:real):real;
begin
if x<=y then
mylessequal:=1
else
mylessequal:=0;
end;

function mygreaterequal(x,y:real):real;
begin
if x>=y then
mygreaterequal:=1
else
mygreaterequal:=0;
end;

function mygreater(x,y:real):real;
begin
if x>y then
mygreater:=1
else
mygreater:=0;
end;

function myless(x,y:real):real;
begin
if x<y then
myless:=1
else
myless:=0;
end;

function myequal(x,y:real):real;
begin
if x=y then
myequal:=1
else
myequal:=0;
end;

function myadd(x,y:real):real;
begin
myadd:=x+y;
end;

function mysub(x,y:real):real;
begin
mysub:=x-y;
end;

function myeor(x,y:real):real;
begin
myeor:=trunc(x) xor trunc(y);
end;

function myor(x,y:real):real;
begin
myor:=trunc(x) or trunc(y);
end;

function mymult(x,y:real):real;
begin
mymult:=x*y;
end;

function mydivid(x,y:real):real;
begin
mydivid:=x/y;
end;

function myand(x,y:real):real;
begin
myand:=trunc(x) and trunc(y);
end;

function mymod(x,y:real):real;
begin
mymod:=trunc(x) mod trunc(y);
end;

function mydiv(x,y:real):real;
begin
mydiv:=trunc(x) div trunc(y);
end;

function mypower(x,y:real):real;
begin
if x=0 then
mypower:=0
else
if x>0 then
mypower:=exp(y*ln(x))
else
if trunc(y)<>y  then
begin
writeln (' Немогу вычислить x^y ');
halt;
end
else
if odd(trunc(y))=true then
mypower:=-exp(y*ln(-x))
else
mypower:=exp(y*ln(-x))
end;

function myshl(x,y:real):real;
begin
myshl:=trunc(x) shl trunc(y);
end;

function myshr(x,y:real):real;
begin
myshr:=trunc(x) shr trunc(y);
end;

function mynot(x,y:real):real;
begin
mynot:=not trunc(x);
end;

function mysinc(x,y:real):real;
begin
if x=0 then
mysinc:=1
else
mysinc:=sin(x)/x
end;

function mysinh(x,y:real):real;
begin
mysinh:=0.5*(exp(x)-exp(-x))
end;

function mycosh(x,y:real):real;
begin
mycosh:=0.5*(exp(x)+exp(-x))
end;

function mytanh(x,y:real):real;
begin
mytanh:=mysinh(x,0)/mycosh(x,0)
end;

function mycoth(x,y:real):real;
begin
mycoth:=mycosh(x,0)/mysinh(x,0)
end;

function mysin(x,y:real):real;
begin
mysin:=sin(x)
end;

function mycos(x,y:real):real;
begin
mycos:=cos(x)
end;

function mytan(x,y:real):real;
begin
mytan:=sin(x)/cos(x)
end;

function mycot(x,y:real):real;
begin
mycot:=cos(x)/sin(x)
end;

function mysqrt(x,y:real):real;
begin
mysqrt:=sqrt(x)
end;

function mysqr(x,y:real):real;
begin
mysqr:=sqr(x)
end;

function myarcsinh(x,y:real):real;
begin
myarcsinh:=ln(x+sqrt(sqr(x)+1))
end;

function mysgn(x,y:real):real;
begin
if x=0 then
mysgn:=0
else
mysgn:=x/abs(x)
end;

function myarccosh(x,y:real):real;
begin
myarccosh:=ln(x+mysgn(x,0)*sqrt(sqr(x)-1))
end;

function myarctanh(x,y:real):real;
begin
myarctanh:=ln((1+x)/(1-x))/2
end;

function myarccoth(x,y:real):real;
begin
myarccoth:=ln((1-x)/(1+x))/2
end;

function myarcsin(x,y:real):real;
begin
if x=1 then
myarcsin:=pi/2
else
myarcsin:=arctan(x/sqrt(1-sqr(x)))
end;

function myarccos(x,y:real):real;
begin
myarccos:=pi/2-myarcsin(x,0)
end;

function myarctan(x,y:real):real;
begin
myarctan:=arctan(x);
end;

function myarccot(x,y:real):real;
begin
myarccot:=pi/2-arctan(x)
end;

function myheavy(x,y:real):real;
begin
myheavy:=mygreater(x,0)
end;

function myfrac(x,y:real):real;
begin
myfrac:=frac(x)
end;

function myexp(x,y:real):real;
begin
myexp:=exp(x)
end;

function myabs(x,y:real):real;
begin
myabs:=abs(x)
end;

function mytrunc(x,y:real):real;
begin
mytrunc:=trunc(x)
end;

function myln(x,y:real):real;
begin
myln:=ln(x)
end;

function myodd(x,y:real):real;
begin
if odd(trunc(x)) then
myodd:=1
else
myodd:=0;
end;

function mypred(x,y:real):real;
begin
mypred:=pred(trunc(x));
end;

function mysucc(x,y:real):real;
begin
mysucc:=succ(trunc(x));
end;

function myround(x,y:real):real;
begin
myround:=round(x);
end;

function myint(x,y:real):real;
begin
myint:=int(x);
end;

function myfac(x,y:real):real;
var n : integer;
r : real;
begin
if x<0 then begin writeln(' Немогу вычислить факториал '); halt; end;
if x = 0 then myfac := 1
else
begin
r := 1;
for n := 1 to trunc ( x ) do
r := r * n;
myfac:= r;
end;
end;

function myrnd(x,y:real):real;
begin
myrnd:=random;
end;

function myrandom(x,y:real):real;
begin
myrandom:=random(trunc(x));
end;

function myevalx(x,y:real):real;
begin
myevalx:=evalx;
end;

function myevaly(x,y:real):real;
begin
myevaly:=evaly;
end;

function myevalz(x,y:real):real;
begin
myevalz:=evalz;
end;

procedure analyse (st:string; var st2,st3:string);
label start;
var pos:integer;
value:real;
newterm,term:string;
begin
term:=st;
start:
if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
newterm:='';
for pos:= 1 to length(term) do
if copy(term,pos,1)<>' ' then newterm:=newterm+copy(term,pos,1);
term:=newterm;
if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
val(term,value,pos);
if pos=0 then begin
analysetmp:=myid;
st2:=term;
st3:='';
exit;
end;
if search(term,'<>',pos) then begin
analysetmp:=myunequal;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+2,length(term)-pos-1);
exit;
end;
if search(term,'<=',pos) then begin
analysetmp:=mylessequal;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+2,length(term)-pos-1);
exit;
end;
if search(term,'>=',pos) then begin
analysetmp:=mygreaterequal;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+2,length(term)-pos-1);
exit;
end;
if search(term,'>',pos) then begin
analysetmp:=mygreater;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'<',pos) then begin
analysetmp:=myless;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'=',pos) then begin
analysetmp:=myequal;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'+',pos) then begin
analysetmp:=myadd;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'-',pos) then begin
analysetmp:=mysub;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'eor',pos) then begin
analysetmp:=myeor;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if search(term,'or',pos) then begin
analysetmp:=myor;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+2,length(term)-pos-1);
exit;
end;
if search(term,'*',pos) then begin
analysetmp:=mymult;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'/',pos) then begin
analysetmp:=mydivid;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'and',pos) then begin
analysetmp:=myand;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if search(term,'mod',pos) then begin
analysetmp:=mymod;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if search(term,'div',pos) then begin
analysetmp:=mydiv;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if search(term,'^',pos) then begin
analysetmp:=mypower;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+1,length(term)-pos);
exit;
end;
if search(term,'shl',pos) then begin
analysetmp:=myshl;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if search(term,'shr',pos) then begin
analysetmp:=myshr;
st2:=copy(term,1,pos-1);
st3:=copy(term,pos+3,length(term)-pos-2);
exit;
end;
if copy(term,1,1)='(' then begin
term:=copy(term,2,length(term)-2);
goto start;
end;
if copy(term,1,3)='not' then begin
analysetmp:=mynot;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,4)='sinc' then begin
analysetmp:=mysinc;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,4)='sinh' then begin
analysetmp:=mysinh;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,4)='cosh' then begin
analysetmp:=mycosh;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,4)='tanh' then begin
analysetmp:=mytanh;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,4)='coth' then begin
analysetmp:=mycoth;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,3)='sin' then begin
analysetmp:=mysin;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,3)='cos' then begin
analysetmp:=mycos;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,3)='tan' then begin
analysetmp:=mytan;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,3)='cot' then begin
analysetmp:=mycot;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,4)='sqrt' then begin
analysetmp:=mysqrt;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,3)='sqr' then begin
analysetmp:=mysqr;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,7)='arcsinh' then begin
analysetmp:=myarcsinh;
st2:=copy(term,8,length(term)-7);
st3:='';
exit;
end;
if copy(term,1,7)='arccosh' then begin
analysetmp:=myarccosh;
st2:=copy(term,8,length(term)-7);
st3:='';
exit;
end;
if copy(term,1,7)='arctanh' then begin
analysetmp:=myarctanh;
st2:=copy(term,8,length(term)-7);
st3:='';
exit;
end;
if copy(term,1,7)='arccoth' then begin
analysetmp:=myarccoth;
st2:=copy(term,8,length(term)-7);
st3:='';
exit;
end;
if copy(term,1,6)='arcsin' then begin
analysetmp:=myarcsin;
st2:=copy(term,7,length(term)-6);
st3:='';
exit;
end;
if copy(term,1,6)='arccos' then begin
analysetmp:=myarccos;
st2:=copy(term,7,length(term)-6);
st3:='';
exit;
end;
if copy(term,1,6)='arctan' then begin
analysetmp:=myarctan;
st2:=copy(term,7,length(term)-6);
st3:='';
exit;
end;
if copy(term,1,6)='arccot' then begin
analysetmp:=myarccot;
st2:=copy(term,7,length(term)-6);
st3:='';
exit;
end;
if copy(term,1,5)='heavy' then begin
analysetmp:=myheavy;
st2:=copy(term,6,length(term)-5);
st3:='';
exit;
end;
if copy(term,1,3)='sgn' then begin
analysetmp:=mysgn;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,4)='frac' then begin
analysetmp:=myfrac;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,3)='exp' then begin
analysetmp:=myexp;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,3)='abs' then begin
analysetmp:=myabs;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,5)='trunc' then begin
analysetmp:=mytrunc;
st2:=copy(term,6,length(term)-5);
st3:='';
exit;
end;
if copy(term,1,2)='ln' then begin
analysetmp:=myln;
st2:=copy(term,3,length(term)-2);
st3:='';
exit;
end;
if copy(term,1,3)='odd' then begin
analysetmp:=myodd;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,4)='pred' then begin
analysetmp:=mypred;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,4)='succ' then begin
analysetmp:=mysucc;
st2:=copy(term,5,length(term)-4);
st3:='';
exit;
end;
if copy(term,1,5)='round' then begin
analysetmp:=myround;
st2:=copy(term,6,length(term)-5);
st3:='';
exit;
end;
if copy(term,1,3)='int' then begin
analysetmp:=myint;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if copy(term,1,3)='fac' then begin
analysetmp:=myfac;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if term='rnd' then begin
analysetmp:=myrnd;
st2:='';
st3:='';
exit;
end;
if copy(term,1,3)='rnd' then begin
analysetmp:=myrandom;
st2:=copy(term,4,length(term)-3);
st3:='';
exit;
end;
if term='x' then begin
analysetmp:=myevalx;
st2:='';
st3:='';
exit;
end;
if term='y' then begin
analysetmp:=myevaly;
st2:='';
st3:='';
exit;
end;
if term='z' then begin
analysetmp:=myevalz;
st2:='';
st3:='';
exit;
end;
if (term='pi') then begin
analysetmp:=myid;
str(pi,st2);
st3:='';
exit;
end;
if term='e' then begin
analysetmp:=myid;
str(exp(1),st2);
sst3:='';
exit;
end;
writeln(' ВНИМАНИЕ : НЕДЕКОДИРУЕМАЯ ФОРМУЛА ');
analysetmp:=myid;
st2:='';
st3:='';
end;

function evalobj.eval:real;
var tmpx,tmpy:real;
begin
if f1=nil then
tmpx:=f1x
else
tmpx:=f1^.eval;
if f2=nil then
tmpy:=f2y
else
tmpy:=f2^.eval;
eval:=f3(tmpx,tmpy);
end;

function evalobj.eval1d(x:real):real;
begin
evalx:=x;
evaly:=0;
evalz:=0;
eval1d:=eval;
end;

function evalobj.eval2d(x,y:real):real;
begin
evalx:=x;
evaly:=y;
evalz:=0;
eval2d:=eval;
end;

function evalobj.eval3d(x,y,z:real):real;
begin
evalx:=x;
evaly:=y;
evalz:=z;
eval3d:=eval;
end;

constructor evalobj.init(st:string);
var st2,st3:string;
error:integer;
begin
f1:=nil;
f2:=nil;
analyse(st,st2,st3);
f3:=analysetmp;
val(st2,f1x,error);
if st2='' then
begin
f1x:=0;
error:=0;
end;
if error<>0 then
new (f1,init(st2));
val(st3,f2y,error);
if st3='' then
begin
f2y:=0;
error:=0;
end;
if error<>0 then
new (f2,init(st3));
end;

destructor evalobj.done;
begin
if f1<>nil then
dispose(f1,done);
if f2<>nil then
dispose(f2,done);
end;

end.

[000159]


Одной строкой

Разбиение шестнадцатиричной величины

Function LoNibble ( X : Byte ) : Byte;
Begin
Result := X And $F;
End;

Function HiNibble ( X : Byte ) : Byte;
Begin
Result := X Shr 4;
End;

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

Label1.Caption := 'Верхняя часть - ' + IntToHex ( HiNibble ( $2E ), 2 );
Label2.Caption := 'Нижняя часть - ' + IntToHex ( LoNibble ( $2E ), 2 );

- Robert Wittig [000849]


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

Alexandr Kordyum советует:

Функция представления чисел с плавающей точкой и нужным числом разрядов.
Пример: Conv(2.005,2) возвращает 2.01; Conv(2.5,0) возвращает 3

function Conv(cs: double; numb: integer): double;
var db, db1, db2: double;
i: int64;
ii, ink, i1: integer;
st: string;
begin
db:=cs-int(cs);
ink:=1;
for ii:=1 to numb do ink:=ink*10;
db1:=db*ink;
db2:=cs*ink*100;
i:=trunc(int(db2)/100);
i1:=trunc(db2-i*100);
if i1>49 then inc(i);
result:=i/ink;
end;

С уважением, Александр. [000897]


Ханойская башня

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

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));
[000013]


Аглоритм (уравнение) для определения восхода/захода солнца и луны (BASIC)

Я нашел алгоритм, написанный на BASIC и вычисляющий восход-заход солнца и восход-заход луны. Может кто-нибудь сможет перенести это на Pascal?

(в случае чего сообщите мне по адресу st_evil@mail.ru)

10 '         Восход-заход солнца
20 GOSUB 300
30 INPUT "Долгота (град)";B5,L5
40 INPUT "Часовая зона (час)";H
50 L5=L5/360: Z0=H/24
60 GOSUB 1170: T=(J-2451545)+F
70 TT=T/36525+1: ' TT = столетия,
80 '            начиная с 1900.0
90 GOSUB 410: T=T+Z0
100 '
110 '  Получаем положение солнца
120 GOSUB 910: A(1)=A5: D(1)=D5
130 T=T+1
140 GOSUB 910: A(2)=A5: D(2)=D5
150 IF A(2)<A(1) THEN A(2)=A(2)+P2
160 Z1=DR*90.833: ' Вычисление зенита
170 S=SIN(B5*DR): C=COS(B5*DR)
180 Z=COS(Z1): M8=0: W8=0: PRINT
190 A0=A(1): D0=D(1)
200 DA=A(2)-A(1): DD=D(2)-D(1)
210 FOR C0=0 TO 23
220 P=(C0+1)/24
230 A2=A(1)+P*DA: D2=D(1)+P*DD
240 GOSUB 490
250 A0=A2: D0=D2: V0=V2
260 NEXT
270 GOSUB 820: ' Вывод информации?
280 END
290 '
300 '        Константы
310 DIM A(2),D(2)
320 P1=3.14159265: P2=2*P1
330 DR=P1/180: K1=15*DR*1.0027379
340 S$="Заход солнца в "
350 R$="Восход солнца в "
360 M1$="В этот день солнце не восходит"
370 M2$="В этот день солнце не заходит"
380 M3$="Солнце заходит весь день"
390 M4$="Солнце восходит весь день"
400 RETURN
410 '     Получение часового пояса
420 T0=T/36525
430 S=24110.5+8640184.813*T0
440 S=S+86636.6*Z0+86400*L5
450 S=S/86400: S=S-INT(S)
460 T0=S*360*DR
470 RETURN
480 '
490 '  Просматриваем возможные события на полученный час
500 L0=T0+C0*K1: L2=L0+K1
510 H0=L0-A0: H2=L2-A2
520 H1=(H2+H0)/2: '  Часовой угол,
530 D1=(D2+D0)/2: '  наклон в
540 '                получасе
550 IF C0>0 THEN 570
560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z
570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z
580 IF SGN(V0)=SGN(V2) THEN 800
590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z
600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2
610 D=B*B-4*A*V0: IF D<0 THEN 800
620 D=SQR(D)
630 IF V0<0 AND V2>0 THEN PRINT R$;
640 IF V0<0 AND V2>0 THEN M8=1
650 IF V0>0 AND V2<0 THEN PRINT S$;
660 IF V0>0 AND V2<0 THEN W8=1
670 E=(-B+D)/(2*A)
680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A)
690 T3=C0+E+1/120: ' Округление
700 H3=INT(T3): M3=INT((T3-H3)*60)
710 PRINT USING "##:##";H3;M3;
720 H7=H0+E*(H2-H0)
730 N7=-COS(D1)*SIN(H7)
740 D7=C*SIN(D1)-S*COS(D1)*COS(H7)
750 AZ=ATN(N7/D7)/DR
760 IF D7<0 THEN AZ=AZ+180
770 IF AZ<0 THEN AZ=AZ+360
780 IF AZ>360 THEN AZ=AZ-360
790 PRINT USING ",  азимут ###.#";AZ
800 RETURN
810 '
820 '   Процедура вывода информации
830 IF M8=0 AND W8=0 THEN 870
840 IF M8=0 THEN PRINT M1$
850 IF W8=0 THEN PRINT M2$
860 GOTO 890
870 IF V2<0 THEN PRINT M3$
880 IF V2>0 THEN PRINT M4$
890 RETURN
900 '
910 '   Фундаментальные константы
920 '     (Van Flandern &
930 '     Pulkkinen, 1979)
940 L=.779072+.00273790931*T
950 G=.993126+.0027377785*T
960 L=L-INT(L): G=G-INT(G)
970 L=L*P2: G=G*P2
980 V=.39785*SIN(L)
990 V=V-.01000*SIN(L-G)
1000 V=V+.00333*SIN(L+G)
1010 V=V-.00021*TT*SIN(L)
1020 U=1-.03349*COS(G)
1030 U=U-.00014*COS(2*L)
1040 U=U+.00008*COS(L)
1050 W=-.00010-.04129*SIN(2*L)
1060 W=W+.03211*SIN(G)
1070 W=W+.00104*SIN(2*L-G)
1080 W=W-.00035*SIN(2*L+G)
1090 W=W-.00008*TT*SIN(G)
1100 '
1110 '    Вычисление солнечных координат
1120 S=W/SQR(U-V*V)
1130 A5=L+ATN(S/SQR(1-S*S))
1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S))
1150 R5=1.00021*SQR(U)
1160 RETURN
1165 '
1170 '     Календарь --> JD
1180 INPUT "Год, Месяц, День";Y,M,D
1190 G=1: IF Y<1583 THEN G=0
1200 D1=INT(D): F=D-D1-.5
1210 J=-INT(7*(INT((M+9)/12)+Y)/4)
1220 IF G=0 THEN 1260
1230 S=SGN(M-9): A=ABS(M-9)
1240 J3=INT(Y+S*INT(A/7))
1250 J3=-INT((INT(J3/100)+1)*3/4)
1260 J=J+INT(275*M/9)+D1+G*J3
1270 J=J+1721027+2*G+367*Y
1280 IF F>=0 THEN 1300
1290 F=F+1: J=J-1
1300 RETURN
1310 '
1320 '   Программа вычисляет время восхода и захода
1330 '   солнца по дате (с точностью до минуты) в пределах
1340 '   нескольких текущих столетий. Производит корректировку, если географическая
1350 '   точка находится в арктическом или антарктическом регионе, где заход или восход солнца
1360 '   на текущую дату может не состояться. Вводимые данные: положительная северная широта и
1370 '   отрицательная западная долгота. Часовой пояс указывается относительно Гринвича
1380 '   (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в
1390 '   "Sky & Telescope" за август 1994, страница 84.

Pascal

Великолепно! Теперь данный алгоритм портирован и в Delphi. Полностью привожу письмо и код модуля Александра Ермолаева, приславшего мне решение этой головоломки:

Аглоритм (уравнение) для определения восхода/захода солнца и луны (Pascal).

Написал я в Делфи. Проект: sunproject.dpr, main.dfm, main.pas. Создайте пустой проект и скопируйте тексты main.dfm, main.pas в соответствующие окошки. Ну сами наверно все знаете, на всякий случай напоминаю.

Александр Ермолаев, swift@glazov.udm.net

sunproject.dpr

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

{
Программа вычисляет время восхода и захода
солнца по дате (с точностью до минуты) в пределах
нескольких текущих столетий. Производит корректировку, если
географическая
точка находится в арктическом или антарктическом регионе, где заход
или восход солнца
на текущую дату может не состояться. Вводимые данные: положительная
северная широта и
отрицательная западная долгота. Часовой пояс указывается относительно
Гринвича
(например, 5 для EST и 4 для EDT). Алгоритм обсуждался в
"Sky & Telescope" за август 1994, страница 84.

}

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.

Вот еще одно решение, от Yuri:

{-------------------}

{$N+}
program Sun;

const
P1       = 3.14159265358;
P2       = 2*P1;
DR       = P1/180;
K1       = 15*DR*1.0027379;

type
TTime = record
Hour, Min, Sec: Extended;
end;
TDate = record
Year, Month, Day: Extended;
end;

type
RequestBlock = record
Latitude,
Longitude: Extended;
HourZone: Word;
Date: TDate;
end;
ReplyBlock = record
SunRise: TTime;
SunRiseAzimuth: Extended;
SunSet: TTime;
SunSetAzimuth: Extended;
end;

function Sign(val: Extended): Integer;
begin
if val < 0 then Sign := -1;
if val > 0 then Sign := 1;
if val = 0 then Sign := 0;
end;

var
A_MATR, D_MATR: array [1..2] of Extended;
B5, L5: Extended; {Широта и долгота}
H: Extended; {Часовая зона}
z0, z1, z: Extended;
g: Extended;
D1, f, J, J3, S, C, A, B, D, E: Extended;
T, TT, T0: Extended;
A5, D5, R5: Extended;
M8, W8: Extended;
A0, D0: Extended;
dA, dD: Extended;
c0: Integer;
p: Extended;
A2, D2: Extended;
L0, L2, H0, H2, H1, t3: Extended;
V0, V1, V2: Extended;
H3, M3: Extended;
H7, N7, D7, AZ: Extended;

procedure ComputeVars;
{
Фундаментальные константы
(Van Flandern & Pulkkinen, 1979)
}
var
L, G, V, U, W: Extended;
begin
L := 0.779072 + 0.00273790931 * T;
G := 0.993126 + 0.0027377785 * T;
L := L - Int(L);
G := G - Int(G);
L := L * P2;
G := G * P2;
V := 0.39785 * Sin(L);
V := V - 0.01 * 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.0001 - 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;

function ComputeSunTime(Rq: RequestBlock; var Rp: ReplyBlock): Byte;
begin
with Rq do
begin
L5 := Longitude/360;
z0 := HourZone /24;
G := 1;
if Date.Year < 1583 then G := 0;
D1 := Int(Date.Day);
f := Date.Day - D1 - 0.5;
J := -Int(7*(Int((Date.Month + 9)/12) + Date.Year)/4);

if (g <> 0) then
begin
S := Sign(Rq.Date.Month - 9);
A := Abs(Date.Month - 9);
J3 := Int(Date.Year + S*Int(A/7));
J3 := -Int((Int(J3/100) + 1)*3/4);
end;
J := J + Int(275*Date.Month/9) + D1 + G*J3;
J := J + 1721027 + 2*G + 367*Rq.Date.Year;
if f < 0 then
begin
f := f+1;
J := J-1;
end;

T := (J - 2451545)+f;
TT := T/36525+1;          {TT = столетия, начиная с 1900.0}

{ Получение часового пояса }
T0 := T/36525;
S := 24110.5 + 8640184.813*T0;
S := S + 86636.6*z0 + 86400*L5;
S := S/86400;
S := S - Int(S);
T0 := S*360*DR;

T := T + z0;
{ Получаем положение Солнца }
ComputeVars;
A_MATR[1] := A5;
D_MATR[1] := D5;
T := T + 1;
ComputeVars;
A_MATR[2] := A5;
D_MATR[2] := D5;
if A_MATR[2] < A_MATR[1] then A_MATR[2] := A_MATR[2] + P2;

{ Вычисление зенита }
z1 := DR*90.833;
S := Sin(Latitude*DR);
C := Cos(Latitude*DR);
z := Cos(z1);
M8 := 0;
W8 := 0;
A0 := A_MATR[1];
D0 := D_MATR[1];
dA := A_MATR[2] - A_MATR[1];
dD := D_MATR[2] - D_MATR[1];

for c0 := 0 to 23 do
begin
p := (c0 + 1)/24;
A2 := A_MATR[1] + p*dA;
D2 := D_MATR[1] + p*dD;
{ Просматриваем возможные события на полученный час }
L0 := T0 + c0*K1;
L2 := L0 + K1;
H0 := L0 - A0;
H2 := L2 - A2;
H1 := (H2 + H0)/2; { Часовой угол, }
D1 := (D2 + D0)/2; { наклон в получасе }

if c0 > 0 then
else V0 := S*Sin(D0) + C*Cos(D0)*Cos(H0) - z;
V2 := S*Sin(D2) + C*Cos(D2)*Cos(H2) - z;

if Sign(V0) <> Sign(V2) then
begin
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
begin
D := Sqrt(D);
E := (-B + D)/(2*A);
if (E > 1) or (E < 0) then E := (-B - D)/(2*A);
t3 := c0 + E + 1/120; { округление }
H3 := Int(t3);
M3 := Int((t3 - H3)*60);

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;

if (V0 < 0) and (V2 > 0) then
begin
Rp.SunRise.Hour := Trunc(H3);
Rp.SunRise.Min := Trunc(M3);
Rp.SunRiseAzimuth := AZ;
M8 := 1;
end;
if (V0 > 0) and (V2 < 0) then
begin
Rp.SunSet.Hour := Trunc(H3);
Rp.SunSet.Min := Trunc(M3);
Rp.SunSetAzimuth := AZ;
W8 := 1;
end;
end;
end;
{ }         A0 := A2;
D0 := D2;
V0 := V2;
end;

{ Вывод информации? }
if (M8 = 0) and (W8 = 0) then
begin
if (V2 < 0) then ComputeSunTime := $A3;
if (V2 > 0) then ComputeSunTime := $A4;
end
else
begin
if (M8 = 0) then ComputeSunTime := $A1;
if (W8 = 0) then ComputeSunTime := $A2;
end;
end;
end;

const
SMessage = 'Заход солнца в ';
RMessage = 'Восход солнца в ';
Message1 = 'В этот день солнце не восходит ';
Message2 = 'В этот день солнце не заходит ';
Message3 = 'Солнце заходит весь день ';
Message4 = 'Солнце восходит весь день ';

var
Rq: RequestBlock;
Rp: ReplyBlock;

begin

with Rq do
begin
Write(' Широта........:'); ReadLn(Latitude);
Write(' Долгота.......:'); ReadLn(Longitude);
Write(' Часовой пояс..:'); ReadLn(HourZone);
Write(' Год...........:'); ReadLn(Date.Year);
Write(' Месяц.........:'); ReadLn(Date.Month);
Write(' День..........:'); ReadLn(Date.Day);
end;
WriteLn;

case ComputeSunTime(Rq, Rp) of
$A1: WriteLn(Message1);
$A2: WriteLn(Message2);
$A3: WriteLn(Message3);
$A4: WriteLn(Message4);
else
Write(RMessage, Rp.SunRise.Hour:0:0, ':', Rp.SunRise.Min:0:0,
';      ');
WriteLn('Азимут: ', Rp.SunRiseAzimuth:2:2);
Write(SMessage, Rp.SunSet.Hour:0:0, ':', Rp.SunSet.Min:0:0, ';
');
WriteLn('Азимут: ', Rp.SunSetAzimuth:2:2);
end;
WriteLn;
end.

[000014]


Выставление и сброс битов

SetWord - слово, которое необходимо установить. BitNum - номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др...). GetBitStat возвращает Истину, если бит установлен и Ложь в противном случае.

{ Слово записывается следующим образом...            }

{ Слово      -  0  0  0  0  0  0 0 0 0 0 0 0 0 0 0 0 }
{ Номер бита - 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 }

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;

[000160]


Как вычислить расстояние, имея широту и долготу.

Попробуйте следующий код. Я им пользуюсь продолжительное время.

Входные данные:
StartLat (начальная широта) = Градусы и сотые доли
StartLong (начальная долгота) = Градусы и сотые доли
EndLat (конечная широта) = Градусы и сотые доли
EndLong (конечная долгота) = Градусы и сотые доли

Выходные данные:
Distance (расстояние) = Расстояние в метрах
Bearing (смещение) = Смещение в градусах

Не забудьте включить модуль Math в список используемых (USES) модулей.

var
// Передаваемые широта/долгота в градусах и сотых долях
StartLat: double;                  // Начальная широта
StartLong: double;                 // Начальная долгота
EndLat: double;                    // Конечная широта
EndLong: double;                   // Конечная долгота

// Переменные, используемые для вычисления смещения и расстояния
fPhimean: Double;                  // Средняя широта
fdLambda: Double;                  // Разница между двумя значениями долготы
fdPhi: Double;                     // Разница между двумя значениями широты
fAlpha: Double;                    // Смещение
fRho: Double;                      // Меридианский радиус кривизны
fNu: Double;                       // Поперечный радиус кривизны
fR: Double;                        // Радиус сферы Земли
fz: Double;                        // Угловое расстояние от центра сфероида
fTemp: Double;                     // Временная переменная, использующаяся в вычислениях
Distance: Double;                  // Вычисленное расстояния в метрах
Bearing: Double;                   // Вычисленное от и до смещение
End

const
// Константы, используемые для вычисления смещения и расстояния
D2R: Double = 0.017453;            // Константа для преобразования градусов в радианы
R2D: Double = 57.295781;           // Константа для преобразования радиан в градусы
a: Double = 6378137.0;             // Основные полуоси
b: Double = 6356752.314245;        // Неосновные полуоси
e2: Double = 0.006739496742337;    // Квадрат эксцентричности эллипсоида
f: Double = 0.003352810664747;     // Выравнивание эллипсоида

begin
// Вычисляем разницу между двумя долготами и широтами и получаем среднюю широту
fdLambda := (StartLong - EndLong) * D2R;
fdPhi := (StartLat - EndLat) * D2R;
fPhimean := ((StartLat + EndLat) / 2.0) * D2R;

// Вычисляем меридианные и поперечные радиусы кривизны средней широты
fTemp := 1 - e2 * (Power(Sin(fPhimean),2));
fRho := (a * (1 - e2)) / Power(fTemp, 1.5);
fNu := a / (Sqrt(1 - e2 * (Sin(fPhimean) * Sin(fPhimean))));

// Вычисляем угловое расстояние
fz :=
Sqrt(Power(Sin(fdPhi/2.0),2)+Cos(EndLat*D2R)*Cos(StartLat*D2R)*Power(Sin(fdLambda/2.0),2)) ;
fz := 2 * ArcSin(fz);

// Вычисляем смещение
fAlpha := Cos(EndLat * D2R) * Sin(fdLambda) * 1 / Sin(fz);
fAlpha := ArcSin(fAlpha);

// Вычисляем радиус Земли
fR := (fRho * fNu) / ((fRho * Power(Sin(fAlpha),2)) + (fNu * Power(Cos(fAlpha),2)));

// Получаем смещение и расстояние
Distance := (fz * fR);
if((StartLat < EndLat) and (StartLong < EndLong)) then
Bearing := Abs(fAlpha * R2D)
else if ((StartLat < EndLat) and (StartLong > EndLong)) then
Bearing := 360 - Abs(fAlpha * R2D)
else if ((StartLat > EndLat) and (StartLong > EndLong)) then
Bearing := 180 + Abs(fAlpha * R2D)
else if ((StartLat > EndLat) and (StartLong < EndLong)) then
Bearing := 180 - Abs(fAlpha * R2D);
end;

Лирическое отступление автора: в качестве входных параметров используются ШИРОТЫ (в множественном числе, ударение на втором слоге), ведь их две. Но хмммм.... долгота(ы???) тоже две, а как будет звучать множественное число? Загадка. Наверное не существует такой формы. (P.S. зато я знаю как будет множественное число от слова ДНО! Слабо?) [000161]


Функция бинарного поиска

function FoundByBinarySearch
(
LowIdx,
HighIdx : LongInt;
var   Result  : LongInt;
const GoalIs  : CompareFunc;
var   Data;
var   Goal
) : Boolean;
var
CompVal : CompareResults;
begin
FoundByBinarySearch := FALSE;

if HighIdx < LowIdx then
Exit;

Result := LowIdx + ((HighIdx-LowIdx) div 2);
CompVal := GoalIs(Result, Data, Goal);

if CompVal = BinEqual then
FoundByBinarySearch := TRUE
else if (LowIdx < HighIdx) then
begin
if CompVal = BinLess then
HighIdx := Result-1
else {CompVal = BinGreater}
LowIdx  := Result+1;
FoundByBinarySearch := FoundByBinarySearch(
LowIdx, HighIdx, Result, GoalIs, Data, Goal)
end
else if (CompVal = BinLess) then
Dec(Result)
end; { function FoundByBinarySearch }

[000406]


Управление битами

Существует ли "человеческий" способ гашения и выставления битов?

{******************************************
Параметр TheBit считается в пределах 0..31
******************************************}
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 TheeBit);
end;

end.

[000624]


Получение переменных окружения DOS I

Какие функции Windows API позволяют получить переменные DOS?

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

Функция GetEnvironmentVariable возвращает значения переменных среды опрашиваемого процесса. Величина также возвращается в виде строки с завершающим нулем.

[000016]


Получение переменных окружения DOS II

...я понял что это безумно трудно, но неужели нет какого-нибудь более простого решения для получения доступа к переменным среды DOS?

Попробуйте мой компонент, код которого я публикую ниже:

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

type
TDosEnvironment = class(TComponent)
public
{ Public объявления класса }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

private
{ Объявления Private-полей }
FDosEnvList: TStringList;
procedure DoNothing(Const Value: TStringList);

protected
{ Объявления Protected-методов }
dummy: Word;
function GetDosEnvCount: Word;

public
{ Public interface объявления }
function GetDosEnvStr(Const Name: String): String;
{ Данная функция является измененной версией функции GetEnvVar,
присутствующей в поставляемом с Delphi модуле WinDos. Она
использует паскалевские строки вместо строк с терминирующим нулем.
}
published
{ Published design объявления }
property DosEnvCount: Word read GetDosEnvCount write dummy;
property DosEnvList: TStringList read FDosEnvList write DoNothing;
end;

procedure Register;

implementation

constructor TDosEnvironment.Create(AOwner: TComponent);
var P: PChar;
i: Integer;
begin
inherited Create(AOwner);
FDosEnvList := TStringList.Create;
P := GetDosEnvironment; { Win API }
i := 0;
while P^ <> #0 do
begin
Inc(i);
FDosEnvList.Add(StrPas(P));
Inc(P, StrLen(P)+1) { Быстрый переход к следующей переменной }
end
end {Create};

destructor TDosEnvironment.Destroy;
begin
FDosEnvList.Free;
FDosEnvList := nil;
inherited Destroy
end {Destroy};

procedure TDosEnvironment.DoNothing(Const Value: TStringList);
begin
MessageDlg('TDosEnvironment.DosEnvList только для чтения!', mtInformation,
[mbOk], 0)
end {DoNothing};

function TDosEnvironment.GetDosEnvCount: Word;
{ Возвращает количество переменных окружения.
}
begin
if Assigned(FDosEnvList) then {!!} Result := FDosEnvList.Count
else
Result := 0;
end {GetDosEnvCount};

function TDosEnvironment.GetDosEnvStr(Const Name: String): String;
{ Данная функция является измененной версией функции GetEnvVar,
присутствующей в поставляемом с Delphi модуле WinDos. Она
использует паскалевские строки вместо строк с терминирующим нулем.
}
var i: Integer;
Tmp: String;
Len: Byte absolute Name;
begin
i := 0;
Result := '';
if Assigned(FDosEnvList) then {!!} while i < FDosEnvList.Count do
begin
Tmp := FDosEnvList[i];
Inc(i);
if Pos(Name,Tmp) = 1 then
begin
Delete(Tmp,1,Len);
if Tmp[1] = '=' then
begin
Delete(Tmp,1,1);
Result := Tmp;
i := FDosEnvList.Count { конец while-цикла }
end
end
end
end {GetDosEnvStr};

procedure Register;
begin
RegisterComponents('Dr.Bob', [TDosEnvironment]);
end {Register};

end.

Успехов, Dr. Bob (drbob@pi.net) [000710]


Изменение системного времени из Delphi

Как я могу сменить системное время Windows 95 из программы, написанной на Delphi 2.0?

Вот правильное решение:

//*************************************************************************
// Функция (раздел 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;

Phil добавляет:

Для изменения системного времени используется сложный спобой (через строки).

DateTimeToSystemTime(tSetDati,Tst);

- работает быстрее и код короче [000017]


События, происходящие в приложениях Delphi при завершении работы Windows

Я провел небольшое исследование, и вот что я выяснил:

При закрытии приложения (используя системное меню или вызывая метод закрытия формы), возникают следующие события:

  1. FormCloseQuery - действие по умолчанию, устанавливает переменную CanClose в значение TRUE и продолжает закрытие формы.
  2. FormClose
  3. FormDestroy

Если приложение активно и вы пытаетесь завершить работу Windows (Shut Down), происходят следующие события (с соблюдением последовательности):

  1. FormCloseQuery
  2. FormDestroy

Мы видим, что метод FormClose в этом случае не вызывается.

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

  1. Windows посылает сообщение WM_QUERYENDSESSION всем приложениям и ожидает ответ.
  2. Каждое приложение получает сообщение и возвращает одну из величин: не равную нулю - приложение готово завершить свою работу, 0 - приложение не может завершить свою работу.
  3. Если одно из приложений возвращает 0, Windows не завершает свою работу, а снова рассылает всем окнам сообщение, на этот раз WM_ENDSESSION.
  4. Каждое приложение должно снова подтвердить свою готовность завершить работу, поэтому операционная система ожидает ответа TRUE, резонно предполагая, что оставшиеся приложения с момента предыдущего сообщения закрыли свои сессии и готовы завершить работу. Теперь посмотрим, как на это реагирует Delphi-приложение: приложение возвращает значение TRUE и немедленно вызывает метод FormDestroy, игнорируя при этом метод FormClose. Налицо проблема.
  5. Завершение работы 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.

Я не тестировал этот код, но могу предположить, что он должен работать. Сообщите, если это не так! [000018]


Завершение работы Windows

Каким образом запустить процесс завершения работы операционной системы (функция ExitWindows) из кода моей программы? Мне необходимо перезапустить операционную систему без перезапуска компьютера.

Ok, приводим обе функции для перезапуска операционной системы:

procedure TMainForm.RestartWindowsBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RestartWindows, 0) then
ShowMessage('Приложение не может завершить работу');
end;

procedure TMainForm.RebootSystemBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RebootSystem, 0) then
ShowMessage('Приложение не может завершить работу');
end;

Функция ExitWindows не была правильно задокументирована Microsoft'ом и не содержит описания возвращаемого значения. Более того, информация о этой функции практически не встречается в других источниках. Вот правильное определение этой функции:

function ExitWindows (dwReturnCode: Longint;
Reserved: Word): Bool;

Улучшения

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

Хотелось бы внести некоторые дополнения с Ваш FAQ, которые касаются вопроса о завершении/перезагрузки Windows. Указанный код не даст результата для Windows NT (и даже, наверное, для Win2000). Ниже - корректно работающий код для Win9x и WinNT. Проверено под D4.

uses Windows;

procedure RebootSystem;
var
handle, ph: THandle;
pid, n: DWORD;
luid: TLargeInteger;
priv: TOKEN_PRIVILEGES;
dummy: PTokenPrivileges;
ver: TOSVERSIONINFO;
begin
ver.dwOSVersionInfoSize := Sizeof(ver);
GetVersionEx(ver);
if ver.dwPlatformId=VER_PLATFORM_WIN32_NT then begin
pid := GetCurrentProcessId;
if OpenProcessToken(ph, TOKEN_ADJUST_PRIVILEGES, handle) then
if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', luid) then begin
priv.PrivilegeCount := 1;
priv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
priv.Privileges[0].Luid := luid;
dummy := nil;
AdjustTokenPrivileges(handle, false, priv, 0, dummy^, n);
end;
end;
ExitWindowsEx(EWX_REBOOT, 0);
end;

Nomadic уточняет:

К сожалению, 32-битная функция ExitWindowsEx не позволяет выполнить простой перезапуск Windows 95/98.

Тем не менее есть 16-битная функция ExitWindows, которая позволяет выполнить перезапуск, будучи вызванной с параметром EW_RESTARTWINDOWS.

Соответственно, в 32-битном приложении Вам либо нужно использовать Thunks, либо запускать дочернее 16-битное приложение, вызывающее данную функцию.

Даже если ты работаешь под Администратором, твоя программка должна запросить дополнительные привилегии. Вот как это делается (на языке Си):
void Reboot (void)
{
  HANDLE hToken;
  TOKEN_PRIVILEGES* NewState;
  OSVERSIONINFO OSVersionInfo;

  OSVersionInfo.dwOSVersionInfoSize = sizeof (OSVERSIONINFO);
  GetVersionEx (&OSVersionInfo);
  if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT)
  {
    OpenProcessToken (GetCurrentProcess (), TOKEN_ADJUST_PRIVILEGES,
      &hToken);
    NewState = (TOKEN_PRIVILEGES*) malloc (sizeof
      (TOKEN_PRIVILEGES) + sizeof (LUID_AND_ATTRIBUTES));
    NewState->PrivilegeCount = 1;
    LookupPrivilegeValue (NULL, SE_SHUTDOWN_NAME,
      &NewState->Privileges[0].Luid);
    NewState->Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
    AdjustTokenPrivileges (hToken, FALSE, NewState, NULL, NULL, NULL);
    free (NewState);
    CloseHandle (hToken);
  }
  ExitWindowsEx (EWX_REBOOT, 0);
}
Здесь иная редакция этой процедуры (на Паскале, без проверки версии ОС) -

Procedure Shutdown(Name:String;   // Имя машины (\\SERVER)
Message:String;  // Сообщение
Delay:Integer;  // Задержка перед рестартом
Restart,CloseAll:Boolean);
var
ph:THandle;
tp,prevst:TTokenPrivileges;
rl:DWORD;
begin
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,ph);
LookupPrivilegeValue(Nil,'SeShutdownPrivilege',tp.Privileges[0].Luid);
tp.PrivilegeCount:=1;
tp.Privileges[0].Attributes:=2;
AdjustTokenPrivileges(ph,FALSE,tp,SizeOf(prevst),prevst,rl);
InitiateSystemShutdown(PChar(name),PChar(Message),Delay,Restart,CloseAll);
ShowMessage(SysErrorMessage(GetLastError)); // Результат
end;

[000019]


Выключение питания 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] [000611]


Управление монитором

Выключить монитор:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить монитор:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

Исправление

_гораздо_ корректнее

SendMessage(HWND_BROADCAST,WM_SYSCOMMAND, 0)

или

SendMessage(HWND_BROADCAST,WM_SYSCOMMAND, -1)

а вариант с Application.handle вообще по-моему нерабочий , ну если и рабочий то в глубоко частном случае !

С уважением, Antony Peter Sadovnikoff.

Дополнение:

Nomadic добавляет еще один способ:

SetSystemPowerState(true,true);

[000020]


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

Решение 1

Алгоритм, применяемый мною:

В блоке 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.

Решение 2

Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.

unit multinst;
{
Применение:
Необходимый код в исходном проекте

if InitInstance then
begin
Application.Initialize;
Application.CreateForm(TFrmSelProject, FrmSelProject);
Application.Run;
end;
Это все понятно (я надеюсь)
}

interface

uses Forms, Windows, Dialogs, SysUtils;

const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;

{ Проверка правильности запуска приложения с помощью описанных ниже функций. }
{ Количество флагов ошибок MI_* может быть более одного. }

function GetMIError: Integer;
Function InitInstance : Boolean;

implementation

const
UniqueAppStr : PChar;   {Различное для каждого приложения}

var
MessageId: Integer;
WProc: TFNWndProc = Nil;
MutHandle: THandle = 0;
MIError: Integer = 0;

function GetMIError: Integer;
begin
Result := MIError;
end;

function NewWndProc(Handle: HWND; Msg: Integer; wParam,
lParam: Longint): Longint; StdCall;
begin

  { Если это - сообщение о регистрации... }
if Msg = MessageID then begin
    { если основная форма минимизирована, восстанавливаем ее }
{ передаем фокус приложению }
if IsIconic(Application.Handle) then begin
Application.MainForm.WindowState := wsNormal;
ShowWindow(Application.Mainform.Handle, sw_restore);
end;
SetForegroundWindow(Application.MainForm.Handle);
end
{ В противном случае посылаем сообщение предыдущему окну }
else
Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;

procedure SubClassApplication;
begin
{ Обязательная процедура. Необходима, чтобы обработчик }
{ Application.OnMessage был доступен для использования. }
WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
Longint(@NewWndProc)));
{ Если происходит ошибка, устанавливаем подходящий флаг }
if WProc = Nil then
MIError := MIError or MI_FAIL_SUBCLASS;
end;

procedure DoFirstInstance;
begin
SubClassApplication;
MutHandle := CreateMutex(Nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError := MIError or MI_FAIL_CREATE_MUTEX;
end;

procedure BroadcastFocusMessage;
{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }
var
BSMRecipients: DWORD;
begin
  { Не показываем основную форму }
Application.ShowMainForm := False;
{ Посылаем другому приложению сообщение и информируем о необходимости }
{ перевести фокус на себя }
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, MessageID, 0, 0);
end;

Function InitInstance : Boolean;
begin
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then
begin
    { Объект Mutex еще не создан, означая, что еще не создано }
{ другое приложение. }
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm:=True;
DoFirstInstance;
result := True;
end
else
begin
BroadcastFocusMessage;
result := False;
end;
end;

initialization
begin
UniqueAppStr := Application.Exexname;
MessageID := RegisterWindowMessage(UniqueAppStr);
ShowWindow(Application.Handle, SW_Hide);
Application.ShowMainForm:=FALSE;
end;

finalization
begin
if WProc <> Nil then
    { Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
end;
end.

Решение 3

VAR MutexHandle:THandle;
Var UniqueKey : string;

FUNCTION IsNextInstance:BOOLEAN;
BEGIN
Result:=FALSE;
MutexHandle:=0;
MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey);
IF MutexHandle<>0 THEN
BEGIN
IF GetLastError=ERROR_ALREADY_EXISTS THEN
BEGIN
Result:=TRUE;
CLOSEHANDLE(MutexHandle);
MutexHandle:=0;
END;
END;
END;

begin
CmdShow:=SW_HIDE;
MessageId:=RegisterWindowMessage(zAppName);
Application.Initialize;
IF IsNextInstance
THEN
PostMessage(HWND_BROADCAST, MessageId,0,0)
ELSE
BEGIN
Application.ShowMainForm:=FALSE;
Application.CreateForm(TMainForm, MainForm);
MainForm.StartTimer.Enabled:=TRUE;
Application.Run;
END;
IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle);
end.

В MainForm вам необходимо вставить обработчик внутреннего сообщения

PROCEDURE TMainForm.OnAppMessage( VAR M:TMSG; VAR Ret:BOOLEAN );
BEGIN
IF M.Message=MessageId THEN
BEGIN
Ret:=TRUE;
// Поместить окно наверх !!!!!!!!
END;
END;

INITIALIZATION
ShowWindow(Application.Handle, SW_Hide);
END.
[000022]


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

program Previns;
uses
WinTypes,
WinProcs,
SysUtils,
Forms,
Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}

type
PHWND = ^HWND;

function EnumFunc(Wnd:HWND; TargetWindow:PHWND): bool; export;
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 GotoPreviousInstance;
var
PrevInstWnd : HWND;
begin
PrevInstWnd := 0;
EnumWindows( @EnumFunc, Longint( @PrevInstWnd ) );
if PrevInstWnd <> 0 then
if IsIconic( PrevInstWnd ) then
ShowWindow( PrevInstWnd, SW_RESTORE )
else
BringWindowToTop( PrevInstWnd );
end;

begin
if hPrevInst <> 0 then
GotoPreviousInstance
else
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.
[000423]


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

Добрые сутки, Валентин.

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

...
Uses syncobjs;
...
Var
CheckEvent: TEvent;
...
procedure TForm1.FormCreate( Sender: TObject );
begin
CheckEvent:= TEvent.Create( nil, false, true, 'MYPROGRAM_CHECKEXIST' );
If CheckEvent.WaitFor( 10 ) <> wrSignaled then
begin
// Сюда попадаем если одна копия уже запущена. Можно, например, сообщить об этом пользователю.
Self.Close;    // Здесь можно завершить программу или сделать еще что-нибудь.
end;
end;

С уважением, Владимир Волосенков.

Uno-v@mail.ru [000489]


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

Пришло от читателя письмо:

Здравствуйте Валентин.

Решил предложить Вам еще один вариант "Как не допустить запуск второй копии программы". Может кому и подойдет...

В этом случае необходимо быть уверенным, что в системе больше нет окон с именем "TForm1" - В.О.

program Project1;

uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var
hwnd: THandle;

begin
hwnd := FindWindow('TForm1', 'Form1');
if hwnd = 0 then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
SetForegroundWindow(hwnd)
end.

Васильев Сергей, vs2000@mail.ru [000750]


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

Пришло от читателя письмо:

Добрый день!
Хотел бы добавить ещё один метод, с помощью которого можно предотвращать запуск второй копии приложения.

program pds;

uses
Windows,
Forms,
Main in 'MAIN.PAS' {MainForm},

const
MemFileSize=127;
MemFileName='one_example';

var
MemHnd:HWND;

{$R *.RES}
begin
MemHnd:=CreateFileMapping(HWND($FFFFFFFF),nil,
PAGE_READWRITE,0,MemFileSize,
MemFileName);
if GetLastError<>ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
with TForm1.Create(nil) do
try
Show;
Update;
Application.CreateForm(TMainForm, MainForm);
finally
Free;
end;
Application.Run;
end else Application.MessageBox('Приложение уже запущено (возможно оно свёрнуто на панели задач): Нажмите кнопку ОК для продолжения работы','Производственно-диспетчерская служба',MB_OK);
CloseHandle(MemHnd);
end.

С уважением,
Васильев Николай.

5 апреля 2000 г., среда
10:15:23 [000780]


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

Тарасов Николай Валентинович советует:

Избежать запуск второй копии можно еще проще (может быть):

в *.dpr файле

ActivatePrevInstance('TForm1','Значение Caption ')

[000883]


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

john@mail.enisey.ru советует:

У меня есть элементарный вариант, проще не бывает. Предлагаемый мной модуль только определяет запущена программа или нет. Я не стал усложнять этот модуль автоматическим изменением имени семафора на случай если две программы захотят использовать этот модуль одновременно. Имея самые скромные навыки в программировании можно придумать семафору своё уникальное имя и переписать его в previnst.pas вовсе не обязательно семафор называть AbraShvabra.

Использование:
В модуле program в части Uses нужно добавить previnst и вы получаете переменную ммм: boolean которая true если копия программы уже запущена.

Пример:

program Project1;

uses
previnst,  windows, Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}
begin
if mmm then begin
ShowWindow(FindWindow('tform1','Имя окна которое активизировать'),
SW_restore);
SetForegroundWindow(FindWindow('tform1','Имя окна которое
активизировать'));
halt; //завершить программу не создавая ничего.
end;

//Тело программы прогры
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

содержание модуля previnst.pas

unit Previnst;

interface

uses  Windows;

var mmm:boolean; //эта переменная если true то программа уже запущена

implementation

var
hMutex : integer;
begin
mmm:=false;
hMutex:=CreateMutex(nil,TRUE,'AbraShvabra');       // Создаем семафор
if GetLastError <> 0 then mmm:=true;       // Ошибка семафор уже создан
ReleaseMutex(hMutex);
end.

[000899]


Каким образом, программным путем, можно узнать о завершении запущенной программы?

16-битная версия:

uses Wintypes,WinProcs,Toolhelp,Classes,Forms;

Function WinExecAndWait(Path : string; Visibility : word) : word;
var
InstanceID : THandle;
PathLen : integer;
begin
  { Преобразуем строку в тип PChar }
PathLen := Length(Path);
Move(Path[1],Path[0],PathLen);
Path[PathLen] := #00;
  { Пытаемся запустить приложение }
InstanceID := WinExec(@Path,Visibility);
if InstanceID < 32 then { значение меньше 32 указывает на ошибку приложения }
WinExecAndWait := InstanceID

else begin
Repeat
Application.ProcessMessages;
until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
WinExecAndWait := 32;
end;
end;

32-битная версия:

function WinExecAndWait32(FileName:String; Visibility : integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
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,                      { указатель командной строки }
nil,                           { указатель на процесс атрибутов безопасности }
nil,                           { указатель на поток атрибутов безопасности }
false,                         { флаг родительского обработчика }
CREATE_NEW_CONSOLE or          { флаг создания }
NORMAL_PRIORITY_CLASS,
nil,                           { указатель на новую среду процесса }
nil,                           { указатель на имя текущей директории }
StartupInfo,                   { указатель на STARTUPINFO }
ProcessInfo) then Result := -1 { указатель на PROCESS_INF }

else begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;

Дополнение

Письмо от читателя:

Очень помог совет из API\Разное: "Каким образом, программным путем, можно узнать о завершении запущенной программы?". Однако хочется внести резонное исправление: вместо

WaitforSingleObject(ProcessInfo.hProcess,INFINITE);

лучше написать:

while WaitforSingleObject(ProcessInfo.hProcess,200)=WAIT_TIMEOUT do
Repaint;

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

Pavel Trubachёv, ptrub@nvtb.ru [000024]


Получение имени модуля

Решение 1

Вот мое решение. Я использовал его во многих программах и смело рекомендую его вам.

procedure TForm1.Button1Click(Sender: TObject);
var
szFileName : array[0..49] of char;
szModuleName : array[0..19] of char;
iSize : integer;
begin
StrPCopy(szModuleName, 'NameOfModule');
iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
SizeOf(szFileName));
if iSize > 0 then
ShowMessage('Имя модуля с полным путем: ' + StrPas(szFileName))
else
ShowMessage('Имя модуля не встречено');
end;

Решение 2

Вот как элегантно решил эту задачу Андрей Иванов (lynxhome@mail.ru):

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(ParamStr(0));
end;

Решение 3

Вот еще одно решение от Степанова Павла (mercury@gin.global-one.ru):

// Включить в Uses SysUtils

procedure TMainForm.Button2Click(Sender: TObject);
var AppDirectory,AppPathName : string;
begin
AppPathName  := Application.ExeName;
AppDirectory    := ExtractFilePath(AppPathName);

messageDlg('Имя программы '+ AppPathName+#13+
'Имя каталога программы '+ AppDirectory
,mtInformation,[mbOK],0);
end;

[000023]


Извлечение из EXE-файла иконки и рисование ее в TImage I

Каким образом извлечь иконку из EXE- и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex : word;
h : hIcon;
begin
IconIndex := 0;
h :=
ExtractAssociatedIcon(hInstance,
'C:\WINDOWS\NOTEPAD.EXE',
IconINdex);

DrawIcon(Form1.Canvas.Handle,
10,
10,
h);
end;
[000021]


Delphi 1

Извлечение из EXE-файла иконки и рисование ее в TImage II

Сперва для получения дескриптора иконки используйте вызов API ExtractIcon, затем назначьте (assign) ее TImage.

Далее смотри электронную документацию. [000389]


Как запустить другую программу?

Для примера посмотрите в Delphi модуль FMXUTIL.PAS:

function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
var
zFileName, zParams, zDir: array[0..79] of Char;

begin
Result := ShellExecute(Application.MainForm.Handle, nil,
StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;

Пример вызова:

executeFile('maker.exe','text_file','c:\maker', SW_SHOWNORMAL);
[000294]


Как с помощью функции Textout вывести на канве прозрачный текст

Вот небольшой участок кода из купленного мною 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;
[000295]


Ассоциативное выполнение

unit UcShell;

interface

uses Classes, SysUtils, Windows, ShellApi, Forms;

{---------------------------------------------------------------}

 function WinExecutableName(const AssociatedFile:string):String;

procedure WinShellOpen(const AssociatedFile:string);
procedure WinShellPrint(const AssociatedFile:string);
procedure WinShellExecute(const Operation,AssociatedFile:string);

{---------------------------------------------------------------}

implementation

Const
cStrBufSize= 80;

{---------------------------------------------------------------}

function WinExecutableName(const AssociatedFile:string):String;
//HINSTANCE FindExecutable(
//    LPCTSTR lpFile,      // указатель на строку с именем файла
//    LPCTSTR lpDirectory, // указатель на строку с директорией по умолчанию
//    LPTSTR lpResult      // указатель на буфер для строки, возвращаемой выполняемым файлом
//   );
 begin
SetLength(result,cStrBufSize); //ucshell
FindExecutable(pchar(AssociatedFile),'',pchar(result));
SetLength(result,strlen(pchar(result)));
end;

//

procedure WinShellExecute(const Operation,AssociatedFile:string);
var
a1:string;
begin
a1:=Operation;
if a1='' then
a1:='open';
ShellExecute(
application.handle     //hWnd: HWND
,pchar(a1)             //Operation: PChar
,pchar(AssociatedFile) //FileName: PChar
,''                    //Parameters: PChar
,''                    //Directory: PChar
,SW_SHOWNORMAL         //ShowCmd: Integer
);
//  GetLastErrorString(0); //ucdialog end;

procedure WinShellPrint(const AssociatedFile:string);
begin
WinShellExecute('print',AssociatedFile);
end;

procedure WinShellOpen(const AssociatedFile:string);
begin
WinShellExecute('open',AssociatedFile);
end;

{-----------------------------------------------------------------}
 end.
[000310]


Delphi 1

Запуск программы с ожиданием

Приведу код функции, вызываемой также, как и 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;
[000352]


Вращение текста

Дан, вот функция, которая тебя, возможно, заинтересует:

procedure MyRotateText(CV : TCanvas; sText:String;
X, Y, Angle:Integer); {угол в градусах}
VAR LogFont : TLogFont;
BEGIN
GetObject(CV.Font.Handle, SizeOf(TLogFont), @LogFont);
LogFont.lfEscapement:= Angle*10;
CV.Font.Handle := CreateFontIndirect(LogFont);
CV.TextOut(X,Y,sText);
END;

К примеру, при задании угла Angle = -90, тект выведется вертикально по направлению сверху вниз.

- Neil

Neil -

Это классно! Спасибо! Но некоторые вопросы все-же имеются:

1) Как только я присвою свойству Handle новый шрифт, старый уничтожается, правильно? А для восстановления оригинальных установок мне необходимо восстановить предыдущий шрифт, правильно? Есть какое-либо простое решение для сохранения оригинального шрифта?

-Dan

Var
SaveFont:   TFont;

SaveFont := TFont.Create;
SaveFont.Assign (CV.Font);
CV.Font := CreateFontIndirect (....)
(....)
CV.Font.Assign (SaveFont);
SaveFont.Free;

Спасибо Oleg Fyodorov за исправление ошибок. [000358]


Delphi 1

Оболочка ShellExecute

Delphi обеспечивает какую-нибудь инкапсуляцию Windows 3.1 API функции ShellExecute?

Это, своего рода неофициально, но файл \DELPHI\DEMOS\DOC\FILMANEX\FMXUTILS.PAS имеет, среди других прочих, функцию ExecuteFile, являющуюся оболочкой функции ShellExecute.

Nick Hodges
Monterey, CA [000364]


Delphi 1

Количество запущенных копий программы

program CrtApp;

uses SysUtils,WinTypes,WinProcs,WinCrt;

var
NumInstances,SavePrevInst : word;

procedure GetInstanceData(hInst,Offset,Size:Word); far; external 'KERNEL';

begin
SavePrevInst := hPrevInst;
NumInstances := 0;
While hPrevInst <> 0 do
begin
GetInstanceData(hPrevInst,Ofs(hPrevInst),SizeOf(hPrevInst));
Inc(NumInstances);
end;
Writeln('Уже запущено ',NumInstances,' копий программы');
hPrevInst := SavePrevInst;
end.
[000385]


Одной строкой

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

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

InvalidateRect(Application.Handle, NIL, True);

... для немедленной перерисовки. [000392]


Delphi 1

Определение окончания работы другого приложения

WinExec сразу после запуска приложения возвращает его дескриптор. Для определения завершения программы вы должны вызывать функцию GetModuleUsage(InstanceID), где InstanceID - дескриптор запущенного функцией WinExec приложения. Если возвращаемый результат содержит ноль, приложение завершило свою работу. Сделайте проверку в таймерном цикле и задача решена. [000458]


Одной строкой

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

var
MyIcon: TIcon;
begin
MyIcon := TIcon. Create;
try
MyIcon.Handle := ExtractIcon(hInstance, 'MYPROG.EXE', 0)
{Здесь можно что-нибудь сделать с иконкой}
finally
MyIcon.Free;
end;
end;

Имейте в виду, что средний параметр должен иметь тип PChar. [000479]


Одной строкой

Поиск окна с помощью функции FindWindow

Вы должны знать имя класса окна или его заголовка. После этого можете написать:

FindWindow('theclassname', nil)

или

FindWindow(nil, 'thecaption')

Если один или оба вызова возвращают 0, то вы использовали неверное имя класса, неверный заголовок, или окно не является самым верхним окном. [000518]


Пример EnumWindows

  1. Создайте форму и разместите на ней два компонента ListBox.
  2. Скопируйте код, показанный ниже.
  3. Запустите SysEdit.
  4. Запустите форму 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.

[000526]


Delphi 1

Управление игрой 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;

[000530]


Извещение об изменениях WIN.INI

Функции SendMessage (Windows API) необходимо несколько параметров. Первым идет дескриптор окна; в нашем случае правильным будет HWND_BROADCAST. Затем идет передаваемое сообщение, WM_WININICHANGE. Последние два параметра - wParam и lParam (word-параметр и long-параметр) сообщения. В нашем случае (для данного конкретного сообщения) wParam должен быть 0, а lParam должен содержать адрес строки с именем измененной секции. Если lParam = NIL (ноль), то система должна проверить на наличие изменений ВСЕ секции, что на деле оказывается ужасно медленным; не посылайте 0, если вы не сделали изменений в нескольких секциях.

Вот пример оповещения об изменениях в секции Desktop:

VAR S : ARRAY[0..40] OF Char;
...
StrCopy(S, 'Desktop');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));

- Neil [000568]


Delphi 1

Активизация предыдущего экземпляра вашей программы

Если внутренняя переменная 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.

[000618]


Delphi 1

Завершение всех работающих приложений

Как мне завершить все работающие задачи?

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

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

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;

[000622]


Delphi 1

Обработка WM_SysCommand

Системное меню в приложениях Delphi ведет двойную жизнь - когда основная форма активна, работает системное меню главной формы, но когда приложение минимизировано, работает системное меню объекта Applictaion. Этот код может оказаться полезным:

CONST SC_UDF = $EFF0;   {должен быть < $F000 и делиться на 16}
procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху');
AppendMenu(GetSystemMenu(Application.Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху');
Application.OnMessage := AppOnMessage;
end;

procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: Boolean);
BEGIN
IF Msg.Message <> WM_SYSCOMMAND THEN Exit;
IF Msg.wParam AND $FFF0 <> SC_UDF THEN Exit;
... здесь вы можете включить код для обработки системного сообщения ...
END;

- Neil J. Rubenking [000804]


Улучшение работы LockWindowUpdate

Danny Thorpe (Borlandeer) посоветовал мне способ избежать использования LockWindowUpdate и, соответственно, избежать излишнего мерцания экрана. Во многих случаях более эффективным способом будет посылка сообщения WM_SETREDRAW, позволяющая блокировать/разблокировать форму, не затрагивая при этом остальные окна.

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

Perform(WM_SETREDRAW, 0, 0);

... и, чтобы возвратиться к нормальному состоянию:

Perform(WM_SETREDRAW, 1, 0);
Refresh;

- Neil Rubenking [000863]


FlashWindow для иконок

В моей Delphi-программе у меня не получается правильно воспользоваться Windows API функцией "FlashWindow". Особенно, когда программа свернута, иконка при этом не мигает.

В это месте Delphi немного "мухлюет". Приложения Delphi имеют невидимую форму уровня приложения, представляемую объектом TApplication.

Когда главная форма имеет нормальное или максимальное состояние, как вы можете наблюдать, FlashWindow работает правильно. Когда приложение минимизировано, иконка, которую вы видите, реально является невидимой формой приложения. Следовательно, FlashWindow вы должны передавать Application.Icon.

- Wayne Niddery [000881]


Delphi 2

WinExecAndWait32

function WinExecAndWait32(FileName:String; Visibility : integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;

begin
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,                      { указатель на строку с командной строкой }
nil,                           { указатель на атрибуты безопасности процесса }
nil,                           { указатель на атрибуты безопасности потока }
false,                         { флаг дескриптора предка }
CREATE_NEW_CONSOLE or          { флаги создания }
NORMAL_PRIORITY_CLASS,
nil,                           { указатель на новый блок среды }
nil,                           { указатель на имя текущего каталога }
StartupInfo,                   { указатель на STARTUPINFO }
ProcessInfo) then Result := -1 { указатель на PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;

- Pat Ritchey [000919]


Delphi 1

WinExecAndWait

Function WinExecAndWait(Path : Pchar; Visibility : word) : word;
var
InstanceID : THandle;
Msg : TMSg;
begin
InstanceID := WinExec(Path,Visibility);
if InstanceID < 32 then { значение меньше 32 говорит об ошибке Exec }
WinExecAndWait := InstanceID
else
begin
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 := 32;
end;
end;

- Pat Ritchey [000920]


Delphi 2

Проблема синтаксиса DrawCaption

Я попытался осуществить один из вызовов API (DrawCaption). Но компилятор сообщил мне о несоответствии количества требуемых параметров количеству, указанному в электронной справке. В справке говорится о 6 параметрах. Но компилятор хочет только 4...

Электронная справка Microsoft несоответствует их же определением в WINDOWS.H функции DrawCaption. Программисты Borland использовали определение из WINDOWS.H. Вот эти четыре параметра:

  1. Дескриптор окна окна (The window handle of the window).
  2. Контекст устройства для окна (A device context for the window)
  3. Прямоугольник (TRect)
  4. Целочисленное поле, содержащее флаги, указанные в электронной справке.
- Pat Ritchey [000933]


Динамические массивы I

Очень простой пример...

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.
[000026]


Динамические массивы II

В. Возможно создавать динамически-изменяющиеся массивы в 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.

[000362]


Delphi 1

Динамические массивы III

Вот "демо-модуль", демонстрирующий три различных способа (далеко не все) создания динамических массивов. Все три способа для распределения достаточного количества памяти из кучи используют 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.

- Robert Wittig [000759]


Динамические массивы IV

Виталий пишет:

Я хочу написать об использовании динамических массивов. Для того чтобы с ними работать можно использовать два вида объявлния в типах

type
DAr = array of real;
var
A: DAr;

или сразу

var A:array of real;

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

SetLength(A,7)

Так мы создали массив состоящий из 7 элементов начиная с 0. Важно! Первый элемент в динамическом массиве всегда нулевой. Для определения верхний границы используем функцию Hihg

I:=High(A);

I - верхняя граница. Для определения длины Length(A), для определения нижней границы Low(A). При нулевой длине массива High, возращает -1. Пример:

var
a,b: array of integer;
begin
SetLength(a,2);
SetLength(b,2);
a[0]:=2;
b[0]:=3;
a:=b;
b[0]:=4;
end;

После этих манипуляций а[0] равно 4. Дело в том при присвоении a:=b не происходит копирование т.к. а, b, это всего лишь указатели на область памяти. Для копирования необходимо использовать функцию Copy.

Я надеюсь что это кому-нибудь поможет в работе.

Всего наилучшего. Виталий

P.S. Не советую изменять длину массивов в DLL, у меня при этом возникала ошибка Acess violation побороть ее мне так и не удалось. [000943]


Массив в Delphi

Раздел 1

Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры 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;

Раздел 2

Самый простой путь - создать массив динамически

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) динамическими сложными массивами и эти функции показали отличный результат.

Раздел 3

Вот способ создания одно- и двухмерных динамических массивов:

(*
--
-- модуль для создания двух очень простых классов обработки динамических массивов
--     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.
[000025]


Заполнения массива случаными неповторяющимися значениями

Письмо от читателя...

Здравствуйте, Валентин. Огромное Вам спасибо за сбор и систематизацию советов по Delphi. Предлагаю Вам интересное решение заполнения массива случаными неповторяющимися значениями. Думаю этот алгоритм небесполезен.

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;

С уважением Дедок Василий.
e-mail: dedokv@mail.ru

He вступая в дискуссию, цитирую следующее письмо:

Заполнять ЦЕЛОЧИСЛЕННЫЙ массив, используя строки -- ЭТО ПОШЛО!

Приведу стандартную процедуру, работает в шесть раз быстрее, не имеет ограничений, да и кода поменьше :)

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;

С уважением, Иваненко Фёдор Григорьевич.

e-mail: theodor_iv@mail.ru [000300]


Delphi 1

Пример массива констант (Array of Const) I

"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;

-Steve [000544]


Delphi 1

Пример массива констант (Array of Const) II

Как использовать "array of const"?

Массив констант (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" электронной справки.

[000937]


Delphi 1

Работа с большими массивами

Распределите память кучи с помощью 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;

[000549]


Использование многомерного массива

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 [000724]


Массив без ограничения типа и размера

Пришло от читателя письмо:

Я тут посмотрел Ваши советы, и понял: это здорово! мне понравилось. Но в них я не нашел (может невнимательно смотрел?) возможности работать с массивами неограниченными по размеру и типу и вообще. Это работает начиная с Delphi 4

//к примеру опишем свой тип
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 [000729]


Delphi 1

Создание многомерного массива

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 [000764]


Delphi 1

Запись массива на диск

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

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 [000787]


Сохранение массива c изображениями

Я решил проблему записи массива TBitmap в файл и его повторного чтения.

Идея заключается в загрузке каждого TBitmap во временный TMemoryStream. Член TMemoryStream.Size информирует о размере данных, которые нужно сохранить на диске. Затем мы пишем размер и сопровождаем его данными типа TFileStream. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

Для процедуры чтения сначала мы должны считать из потока размер данных TBitmap. Затем мы распределяем область для типа TMemoryStream полученного размера и считываем данные. Затем переписываем из TFileStream в TMemoryStream. И, наконец, мы читает из TMemoryStream сам TBitmap. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

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

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

procedure TMainForm.SaveBoard;
var
MemoryStream: TMemoryStream;
FileStream  : TFileStream;
Writer      : TWriter;
Buffer      : Pointer;
Size        : Longint;
Column      : Integer;
Row         : Integer;
begin
MemoryStream := TMemoryStream.Create;
FileStream := TFileStream.Create (SaveFilename, fmCreate);
Writer := TWriter.Create (FileStream, $1000);
try
for Column := 0 to 4 do for Row := 0 to 4 do
begin
MemoryStream.Clear;
Bitmaps[Column, Row].SaveToStream (MemoryStream);
Buffer := MemoryStream.Memory;
Size := MemoryStream.Size;
Writer.WriteInteger (Size);
Writer.Write (Buffer^, Size);
end;
finally
Writer.Free;
FileStream.Free;
MemoryStream.Free;
end;
end;

procedure TMainForm.Open1Click(Sender: TObject);
var
MemoryStream: TMemoryStream;
FileStream  : TFileStream;
Buffer      : Pointer;
Reader      : TReader;
Column       : Integer;
Row         : Integer;
Size        : Longint;
begin
OpenDialog2.Filename := SaveFilename;
if not OpenDialog2.Execute then Exit;
MemoryStream := TMemoryStream.Create;
FileStream := TFileStream.Create (OpenDialog2.Filename, fmOpenRead);
Reader := TReader.Create (FileStream, $1000);
try
for Column := 0 to 4 do for Row := 0 to 4 do
begin
Size := Reader.ReadInteger;
MemoryStream.SetSize (Size);
Buffer := MemoryStream.Memory;
Reader.Read (Buffer^, Size);
Bitmaps[Column, Row].LoadFromStream (MemoryStream);
end;
finally
Reader.Free;
FileStream.Free;
MemoryStream.Free;
end;
DrawGrid1.Repaint;
SaveFilename := OpenDialog2.Filename;
Caption := 'Bingo-создатель - ' + ExtractFilename (SaveFilename);
end;

Опубликовал Michael Vincze (102224.3340.compuserve.com) [000828]


Delphi 1

Массив констант во время выполнения приложения

...хорошо, непосредственно это синтаксис не поддерживает, поскольку массив констант Array of Const подобен открытым массивам, главным образом в части характеристик времени компиляции. Но вы можете обойти этот неприятный момент, обладая хотя бы начальными знаниями того, как реализован открытый массив. Что нам для этого необходимо: динамически размещенный массив array of TVarRec, который "принимает" ваши параметры, и "псевдоним" (alias) функции Format, позволяющий работать с таким массивом без "ругани" со стороны компилятора.

Type
{ объявляем тип для динамического массива array of TVarRecs }
TVarArray = Array [0..High(Word) div Sizeof(TVarRec)-1] of TVarRec;
PVarArray = ^TVarArray;

{ Объявляем alias-тип для функции Format. Передаваемые параметры будут иметь в стеке тот же самый порядок вызова, что и при нормальном вызове Format }
FormatProxy = Function( Const aFormatStr: String; Var aVarRec: TVarRec; highIndex: Integer ): String;

{ AddVarRecs копирует параметры, передаваемые в массиве A в pRecs^, начиная с pRecs^[atIndex]. highIndex - самый большой доступный индекс pRecs, число распределенных элементов - 1. }
Procedure AddVarRecs( pRecs: PVarArray; atIndex, highIndex: Integer; Const A: Array of Const );
Var
i: Integer;
Begin
If pRecs <> Nil Then
For i := 0  To High(A) Do Begin
If atIndex <= highIndex Then Begin
pRecs^[atIndex] := A[i];
Inc(atIndex);
End { If }
Else
Break;
End; { For }
End; { AddVarRecs }

procedure TScratchMain.SpeedButton2Click(Sender: TObject);
Var
p: PVarArray;
S: String;
Proxy: FormatProxy;
begin
{ распределяем массив для четырех параметров, индексы - 0..3 }
GetMem(p, 4*Sizeof(TVarRec));
try
{ добавляем параметры последующими вызовами AddVarRecs }
AddVarRecs( p, 0, 3, [12, 0.5, 'Шаблон']);
AddVarRecs( p, 3, 3, ['Тест'] );

{ получаем полномочия Format }
@Proxy := @SysUtils.Format;

{ Вызов с динамически сгенерированным массивом параметров. Естественно, строка формата может также быть сформирована и во время выполнения программы. }
S := Proxy('Целое: %d, Реальное: %4.2f, Строки: %s, %s', p^[0], 3 );

{ выводим результат }
ShowMessage(S);
finally
FreeMem( p,4*Sizeof(TVarRec));
end;
end;

Я надеюсь вы поняли принцип. Естественно, имеются ограничения. Вы можете передавать в AddVarRecs числовые величины, строковые переменные и литералы, но не в коем случае не строковые выражения! В этом случае компилятор должен для хранения результата сформировать в стеке временную строку, передать ее в AddVarRecs (или лучше по адресу в TVarRec), и она может прекратить свое существование или может быть перезаписана в стеке другими данными, если в конечном счете вы передадите в Proxy целый массив!

Тестировалось только в Delphi 1.0!

- Peter Below [000955]


Шаблон массива переменной длины

Может ли кто мне подсказать как динамически создать массив записей и получить доступ к отдельным элементам?

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

Я разработал то, что я называю шаблоном массива переменной длины "для бедных людей"...

unit %s;

{ -----------------------------------------------------------
ШАБЛОН МАССИВА ПЕРЕМЕННОЙ ДЛИНЫ

Вы можете использовать этот шаблон для создания массива
переменной длины любого типа данных.

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

interface

const
%MaxCapacity = High( Cardinal ) div SizeOf( % );

type
T%Index = 0..%MaxCapacity - 1;

T%s = array[ T%Index ] of %;
P%s = ^T%s;

function %sSize( Capacity: T%Index ): Cardinal;
function Get%s( Capacity: T%Index ): P%s; function Resize%s( var P: P%s;
OldCapacity, NewCapacity: T%Index ): P%s;
procedure Free%s( var P: P%s; Capacity: T%Index );

implementation
uses SysUtils;

function %sSize( Capacity: T%Index ): Cardinal;
begin
Result := Capacity * SizeOf( % );
end;

function Get%s( Capacity: T%Index ): P%s;
begin
GetMem( Result, %sSize( Capacity ));
end;

function Resize%s( var P: P%s;
OldCapacity, NewCapacity: T%Index ): P%s;
begin
ReAllocMem( P, %sSize( OldCapacity ), %sSize( NewCapacity ));
end;

procedure Free%s( var P: P%s; Capacity: T%Index );
begin
FreeMem( P, %sSize( Capacity ));
P := nil;
end;

end.

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

Вот модуль, использующий после операции поиска и замены (см. выше) тип записи 'MyRecord', содержащий также определение этой записи. Поскольку "MyRecords" было очень длинным для имени модуля, я укоротил его. Имейте в виду, что PMyRecords - тип вашего переменного массива, если вы используете этот модуль.

unit MyRecs;
interface

type
MyRecord = record
AnInt: Integer;
AString: string[ 10 ];
end;

const
MyRecordMaxCapacity = High( Cardinal ) div SizeOf( MyRecord );

type
TMyRecordIndex = 0..MyRecordMaxCapacity - 1;

TMyRecords = array[ TMyRecordIndex ] of MyRecord;
PMyRecords = ^TMyRecords;

function MyRecordsSize( Capacity: TMyRecordIndex ): Cardinal;
function GetMyRecords( Capacity: TMyRecordIndex ): PMyRecords;
function ResizeMyRecords( var P: PMyRecords;
OldCapacity, NewCapacity: TMyRecordIndex ): PMyRecords;
procedure FreeMyRecords( var P: PMyRecords; Capacity: TMyRecordIndex );

implementation
uses SysUtils;

function MyRecordsSize( Capacity: TMyRecordIndex ): Cardinal;
begin
Result := Capacity * SizeOf( MyRecord );
end;

function GetMyRecords( Capacity: TMyRecordIndex ): PMyRecords;
begin
GetMem( Result, MyRecordsSize( Capacity ));
end;

function ResizeMyRecords( var P: PMyRecords;
OldCapacity, NewCapacity: TMyRecordIndex ): PMyRecords;
begin
ReAllocMem( P, MyRecordsSize( OldCapacity ),
MyRecordsSize( NewCapacity ));
end;

procedure FreeMyRecords( var P: PMyRecords; Capacity: TMyRecordIndex );
begin
FreeMem( P, MyRecordsSize( Capacity ));
P := nil;
end;

end.

Наконец, вот пример использования массива переменной длины. Помните, что указатель должен использоваться с символом "^"...

procedure TForm1.Button1Click( Sender: TObject );
var
P: PMyRecords;
begin
P := GetMyRecords( 10 );
try
P^[ 0 ].AnInt := 2001;
P^[ 0 ].AString := 'Космическая одиссея';
finally
FreeMyRecords( P, 10 );
end;
end;

- Ed Jordan [000990]


Delphi 1

Эмулятор плавающей точки

Имеется ошибка при системной эмуляции плавающей точки - квадратный корень отрицательного числа вычисляется неправильно и не может быть перехвачен. [000335]


TurboPascal

Предел сегмента данных в 64K

Из раскопок:

  • В: Может ли Borland Pascal использовать статические переменные с размером более чем 64 килобайта?
  • О: Нет!
  • В: Вы говорите *статические* переменные. Неужели есть что-то еще, с чем можно работать?
  • О: Да, смотри ниже одно из решений проблемы. Можете не тратить время на чтение следующего текста, все равно это не работает, можете смело скроллировать вниз.
  • В: Поможет разделение большого массива на несколько маленьких (все элементы меньше чем 64k, но в сумме больше чем 64k)?
  • О: Нет!
  • В: Поможет объявление нескольких переменных в модуле?
  • О: Нет!
  • В: Поможет объявление чего-либо в секции реализации модуля?
  • О: Нет!
  • В: Поможет использование защищенного режима Borland Pascal 7?
  • A: Нет!
  • В: Вы уверены??
  • О: Да!!
  • В: Почему??
  • О: Во-первых, все программы, созданные на Borland Pascal, для любых переменных используют только один сегмент данных, во-вторых, процессоры Intel 80xxx ограничивают размер сегмена 64 килобайтами.
  • В: Это глупо!!
  • О: Скажите это Borland!! (Или Intel, ...или обоим).
  • В: Есть ли выход из тупика?
  • О: Да! Возможны два решения:

    1) не используйте *СТАТИЧЕСКИЕ* переменные для хранения данных большого размера. В итоге это позволит разместить более чем 64k данных, но весь массив данных в 64k не поместится, таким образом вы его поделите на несколько частей, что не является решением проблемы. Сделайте переменные динамическими.

    2) используйте другой компилятор: есть несколько доступных компиляторов языка Pascal, которые более-менее Borland-совместимые и не имеют таких ограничений (они 32-битные).

  • В: Почему Borland Pascal не имеет 32-битного компилятора?
  • О: Да, он весьма древний. Сообщите Borland, что вы хотите новую версию.
  • В: Что такое не-статическая память?
  • О: Для примера Куча, XMS, EMS, ... Куча доступна непосредственно, для XMS необходим драйвер (himem.sys), для EMS тоже (HIMEM.SYS + EMM386.EXE) и он обычно доступен не на всех компьютерах, так что лучше использовать XMS вместо EMS.
  • В: Что такое Куча?
  • О: Куча - вся свободная память ниже 640-килобайтной границы в режиме реального времени, в защищенном режиме (доступном только в Borland Pascal 7) - вся свободная память ниже 16-мегабайт (обычно *ВСЯ* свободная память, но мы здесь говорим о Borland Pascal).
  • В: Каким образом можно воспользоваться Кучей?
  • О: Доступ к памяти Кучи возможен только с помощью указателей. Посмотрите на этот пример, вы можете использовать эту технологию в ваших программах:

    type
    arr    = array [1..30000] of longint; { это ваши данные }
    arrptr = ^arr;                        { это указатель на данные }
    var
    data : arrptr;       { это переменная, содержащая указатель }
    begin
    if memavail < sizeof(arr) then halt;  { проверяем наличие доступной памяти }
    new (data);                           { распределяем память }
    for i := 1 to 30000 do data^[i]:=0;   { используем ее, обратите здесь внимание на символ ^ !! }
    dispose (data);                       { освобождаем память }
    end.

    Примечание: данные можно описать и таким способом:

    var
    data : array [1..10000] of arrptr;

  • В: Есть ли недостатки у данного решения?
  • О: Да! Это медленно и немного опасно.
  • В: Опасность заключается в использовании Кучи?
  • О: Да!

    Всегда распределяйте память Кучи прежде, чем вы решитесь ее использовать. В противном случае вы можете получить одну из следующих ошибок системы: при использовании программ, разработанных на C - "General Protection Violation" (Общее нарушение защиты), разработанных с использованием других инструментов и языков - "Protected Mode Exception #13" (Исключительная ситуация защищенного режима) или иные. В режиме реального времени программа обычно не вызывает такую ошибку, она просто молча перезапишет другие данные, или то, что попадется под руку - саму себя, другие программы, DOS, все, что может оказаться в памяти.
    Это может повлечь за собой все что угодно, вплоть до холодной перезагрузки с выключением PC от сети, но может и не иметь никакого эффекта. В особо крайнем случае возможна перезапись данных на жестком диске. Но это в теории и вряд ли возможно.

  • В: Как я могу использовать XMS память?
  • О: По адресу http://www.brain.uni-freiburg.de/~klaus/pascal/sources/ расположен модуль, который позволяет использовать XMS.
  • В: Как насчет других компиляторов Pascal?
  • О: Проверьте FPK-Pascal и GNU-Pascal. Они оба являются свободно распространяемыми 32-битными компиляторами Pascal для DOS и более-менее Borland-совместимые. Если вам необходим компилятор Pascal для Linux или OS/2, то два вышеупомянутых компилятора доступны также и для этих операционных систем, плюс некоторые другие, смотри http://www.brain.uni-freiburg.de/~klaus/pascal/web-list.html.
  • В: Это звучит так, будто автор не любит Borland Pascal, не правда ли?
  • О: Неправда, я *люблю* их и пользуюсь ими все время, но я *не люблю*, когда Borland не предлагает их новые версии.
  • В: Как насчет Delphi?
  • О: Не доступен для DOS,
    Не доступен для Linux,
    Не доступен для OS/2.
[000147]


Delphi 1

???? Слишком большой сегмент данных ???? I

Я получаю сообщение 'Data segment too large'. Что за проблема и как мне ее решить?

В Windows 3.1 приложениях три специализированных области памяти занимают один (!) сегмент памяти объемом 64K: системная 'локальная куча' и два сегмента, содержащие все глобальные и инициализированные константы. Эта область памяти может быть израсходована очень быстро.

Вот почему W3.1 приложения практически -ничего- не хранят в куче или в глобальных переменных. Предпочтительно сохранение -указателей-. Вот объяснение того, почему в Delphi 'объект как указатель.'

В вашем случае рекомендую все большие глобальные переменные переместить в общий блок данных, который распределяет при запуске сама программа (как объект) и уничтожить их при выходе. Вы можете просмотреть содержимое сегмента данных, установив флажок 'linker map' в 'detailed' и просмотрев сегмент 'DATA'. Все данные, записываемые в данный участок памяти, пытаются расположиться в нижней части этого 64K-сегмента.

[000269]


Delphi 1

???? Слишком большой сегмент данных ???? II

Как найти необъяснимые незаполненные области в сегментах данных:

Я знаю, что это нелегкий способ, но я знаю что он будет работать, поскольку я делал это сам. Используйте DCC.EXE, компилируйте ваш полный проект (DPR) и добавляйте к командной строке опцию /GD, это позволит создать .MAP-файл. MAP-файл создан по правилам форматирования текстового файла, поэтому вы можете затем загрузить его в Delphi и там изучать.

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

Следующая секция MAP-файла является листингом ВСЕХ Public-объявлений. Публичные объявления включают в себя переменные (например, TForm), возвращаемые величины и каждый объект, определенный в VCL. Наиболее важные здесь элементы списка - определения всех переменных в программе и насколько они большие (устанавливается косвенно).

Самый минимально-возможный проект Delphi создаст вам список из нескольких сотен записей.

Для нашего примера я использовал пустой проект, который Delphi создает вам автоматически: сохраните проект и модуль под любым именем каким вы хотите, закройте проект и выйдите из Delphi. Я использую имена DATAP.DPR и DATAU.PAS.

В DOS-строке введите следующую команду:

      DCC DATAP.DPR /GD
Теперь у вас будет скомпилированный проект и созданный файл DATAP.MAP. Снова загрузите Delphi и откройте в нем MAP-файл. Смотрим адрес сегмента DATA.
  0008:0000    0E34H   DATA               DATA
В нашем примере, как вы можете увидеть, VCL требует минимум $0E34 (3636) байт для сегмента данных (Data Segment). Теперь перейдем ко второй секции (ниже по тексту) и увидим начальные адреса вашего сегмента DATA.
  0008:055A       CreationControl
  0008:055E       VBXHook
  .......         ..........
В любом проекте, который я когда-либо создавал, первые $0040 байт в MAP-файле всегда резервируются чем-то неопределенным. Вставляемая по умолчанию часть листинга всегда начинается с "CreationControl".

В проектах, где я имею хотя бы одно объявление TYPED CONST DATA, всегда указывается первый начальный адрес с отступом xxxx:0040 и перед "CreationControl", который, оказывается, сам занимает около 1300 байт.

Используя шестнадцатиричный адрес в качестве указателя, вы запросто можете вычислить разницу между распределенной памятью и памятью, реально занимаемую каждым элементом. Для этого понадобиться научный калькулятор, для этой цели подойдет калькулятор, поставляемый с Windows 3.0, только не забудьте переключить его в режим scientific (научный). Продолжаем: "встроенные" данные обычно начинаются с "CreationControl"/"HaltVector", который тут же сопровождается переменным указателем на вашу главную форму (4 байта).

  0008:09DC       HaltVector
  0008:0A32       Form1
  0008:0B60       NewStyleControls

   .......         ..........

  0008:0D84       LongDayNames
Все переменные для каждой формы приведены здесь в том же порядке, как они объявлены в модуле. Строка с "NewStyleControls" обычно знаменует конец секции с вашими переменными и начало остальных "встроенных" данных, которые, обычно, заканчиваются строкой "LongDayNames".

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

- Dennis Passmore [000832]


Delphi 1

Динамическое распределение памяти I

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, sizeof(char));
end;
end;

[000361]


Delphi 1

Динамическое распределение памяти II

Как мне уменьшить количество занимаемой мной памяти в сегменте данных? (или как мне распределять память динамически?)

Скажем, ваша структура данных выглядит похожей на эту:

type
TMyStructure = record
Name: String[40];
Data: array[0..4095] of Integer;
end;

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

var
MyData: TMyStructure;

объявляете указательный тип,

type
PMyStructure = ^TMyStructure;

и переменную этого типа,

var
MyDataPtr: PMyStructure;

Такой указатель занимает всего лишь четыре байта сегмента данных.

Прежде, чем вы сможете использовать структуру данных, вы должны распределить ее в куче:

New(MyDataPtr);

и получить к ней доступ через глобальные данные любым удобным для вас способом. Единственное отличие от традиционного способа заключается в необходимости использования символа "^" для обозначения указателя на данные:

MyDataPtr^.Name := 'Советы по Delphi';
MyDataPtr^.Data[0] := 12345;

И, наконец, после использования памяти, освободите ее:

Dispose(MyDataPtr);

[000936]


Delphi 1

StrAlloc и GetMem

StrAlloc непосредственно использует GetMem, поэтому обе функции живут за счет Кучи. StrAlloc имеет преимущество: он распределяет на два байта больше, чем вы просите и там хранит размер размещенного блока. Поэтому StrDispose знает сколько памяти освободить и вы можете этого не помнить (в отличие от GetMem/FreeMem). Не смешивайте при работе эти две функциональные пары, иначе вы будете потрясены количеством возникающих ошибок! [000491]


Быстрое сравнение памяти

Я ищу функцию, которая была бы эквивалентом сишной функции 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 [000860]


Delphi 1

Управление размером сегмента данных

Тема: Управление размером сегмента данных

Ошибка "Data Segment too large" (сегмент данных слишком велик) возникает в Delphi 16-битных приложениях в случае, когда размер статических данных, стека и локальной кучи превышает предел приложений Windows, установленный в 64К. В данном совете обсуждается тема идентификации и изменения части вашего кода, которая поглощает память в сегменте данных, и как, собственно, управлять этим ограниченным ресурсом.

Из чего состоит сегмент данных?

Task header: 	16 байт различной системной информации Windows
(заголовок
 задачи)
Static data: 	Содержит глобальные переменные и типовые
(статические    константы
 данные)
Stack:          Хранит локальные переменые, распределенные
(стек)		процедурами и функциями. Размер стека по
                по умолчанию 16К и может быть изменен на
                странице Options|Project|Linker.
Local heap: 	Используется Windows для временного хранения и
(локальная	по умолчанию имеет размер 8К. Не устанавливайте
 куча)		разнер локальной кучи, равным 0. Windows при
                необходимости может увеличить данную область.
Как мне узнать полный размер сегмента данных?

Для того, чтобы получить размер статических данных 16-битного приложения Delphi, стека и локальной кучи для проекта, скомпилируйте проект и выберите в меню Delphi пункт Compile|Information. Для нового проекта с одной формой диалог покажет следующую информацию:

Source compile:	 12 lines (скомпилировано 12 строк исходного кода)
Code size:	 128981 bytes (размер кода 128981 байт)
Data size:	 3636 bytes (размер данных 3636 байт)
Stack size:	 16384 bytes (размер стека 16384 байт)
Local Heap size: 8192 bytes (размер локальной кучи 8192 байт)
Приложение Delphi начинается с объявления в модуле статических данных, тем самым обеспечивая функциональную инициализацию. Если единственная глобальная переменная является именем формы, то приложение занимает уже, по крайней мере, 3,636 байт. Добавляя вторую форму, размер увеличивается только до 3640 -- добавляется только размер глобальной переменной, необходимой для объявления второй формы.

var
Form2: TForm2; { 4-х байтный указатель }

Общий размер сегмента данных (сумма статических данных, стека и локальной кучи) составляет 28,212 байт:

Data size:	  3,636
Stack size:	 16,384
Local Heap size:  8,192
-----------------------
              28,212
Какие части моего проекта увеличивают размер данных?
  • Переменные, объявленные в секции interface и implementation.
  • Типизированные константы, объявленные в любом месте приложения.
Пример объявления типизированной константы:

const
MyConst: integer = 100;

Модули, объявленные в списке Uses, и компоненты могут содержать код с объявлениями глобальных переменных или типизированных констант. Например, TBitBtn добавляет к проекту 180 байт, и, по крайней мере, 132 байт резервируются для типизированных констант и глобальных переменных, объявленных в модуле Buttons.Pas. При добавлении дополнительных 10 компонентов TBitBtn, размер проекта после первых 180 байт не увеличится.

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

unit Test;

interface

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

{ Используемые в модуле функции могут иметь глобальные переменные и типизированные константы, которые увеличивают размер сегмента данных. }

type
{ Объекты класса хранятся в глобальной куче, не в сегменте данных}
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
public
{ MyInteger и MyString хранятся в глобальной куче. }
MyInteger: Integer;
MyString: String;
end;

const
{ MyConst - типизированная константа и сохраняется в области статических данных сегмента.
Минимизируйте количество типизированных констант. }
MyConst: integer = 23;

var
{ Form1 - глобальная переменная и хранится в области статических данных сегмента. Вы должны минимизировать число и размер глобальных переменных. Form1 является указателем и занимает только четыре байта. }
Form1: TForm1;
{ MyGlobalString занимает 256 байт, даже если строка состояла бы всего из нескольких символов. }
MyGlobalString: string;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
{ MyLocal - локальная переменная и не хранится в сегменте данных. }
MyLocal: String;
begin
MyLocal := 'Тестовое приложение';
Label1.Caption := MyLocal
end;

end.

Как влияют компоненты на размер данных?

Вот список компонентов со страниц Standard, Additional, Data Access и Data Control (часть списка) палитры компонентов. В списке приведен размер компилиции после добавления к новому проекту единственного экземпляра компонента. Список отсортирован согласно количеству расходуемой памяти:

  Компонент	 Прил.	Байтов
           в 	свыше
           байт.	3,636

  table		 4272	636
  batchmove	 4272	636
  storedproc	 4258	622
  query		 4250	614
  database       4036	400
  datasource	 3886	250
  outline	 3838	202
  bitbtn	 3816	180
  stringgrid 	 3794	158
  drawgrid  	 3790	154
  maskedit  	 3762	126
  memo		 3750	114
  report	 3722	86
  listbox	 3704	68
  edit		 3694	58
  tabset	 3692	56
  combobox	 3674	38
  scrollbar   	 3654	18
  button	 3652	16
  checkbox 	 3652	16
  radiobutton	 3652	16
  radiogroup	 3652	16
  panel		 3650	14
  label		 3648	12
  speedbutton	 3646	10
  header	 3644	8
  scrollbox  	 3644	8
  notebook  	 3638	2
  menu		 3636	0
  groupbox 	 3636	0
  tabbednotebook 3636	0
  image		 3636	0
  shape		 3636	0
Как управлять размером сегмента данных?
  1. Избегайте объявления глобальных переменных и типизированных констант, особенно больших массивов. Вместо этого объявляйте тип и указель на него. Затем пользуйтесь функциями для работы с памятью, например, Getmem, которая распределит вам память в глобальной куче. Это уменьшит использование ресурсов в сегменте данных до 4 байт, необходимых для переменной указательного типа. Смотрите ниже пример кода.
  2. Отдавайте себе отчет о влиянии компонентов. Смотри выше.
  3. Если у вас имеется множество строк, или массив строк, распределяйте это динамически. Примечание: по умолчанию длина строки равна 255 символам -- объявляйте, где это возможно, специфический размер строки: (например, MyShortString: string[20]).
  4. При необходимости работать с большим количеством строк рекомендуется использовать объект TStringList.
  5. Тип Pchar, "указатель на строку", может быть использован для динамического создания и управления символьными строками, используя при этом небольшое размер сегмента данных. Смотри раздел электронной справки "String-handling routines (Null-terminated)" (подпрограммы обработки строк (с терминирующим нулем)).
  6. Информация, необходимая для работы с памятью, доступна в Object Pascal Language Guide (руководство по языку Object Pascal), OBJLANG.ZIP и может быть загружена из Compuserve, форум DELPHI, или из Интернета по адресу www.borland.com/TechInfo/delphi/whatsnew/dwnloads.html.
Альтернатива для глобального объявления большой структуры

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

  1. { Объявление TMyStructure не вызовет никаких изменений в размере сегмента данных. }
    TMyStructure = record
    Name: String[10];
    Data: array[0..9] of Integer;
    end;

    var
    Form1: TForm1;

    { Объявление MyStructure вызовет увеличение
    размера сегмента памяти на 32 байта:
    указатель Mystructure = 1 байт
    Name = 11 байт (10 символов + байт длины)
    Data = 20 байт (10 * 2 байт на целое)
    }
    MyStructure: TMyStructure;

  2. { Объявление TMyStructure не вызовет никаких изменений в размере сегмента данных. }
    PMyStructure = ^TMyStructure;
    TMyStructure = record
    Name: String[10];
    Data: array[0..9] of Integer;
    end;

    var
    Form1: TForm1;
    { MyDataPtr вызывает увеличение на 4 байта
    для размещения указательной переменной. }
    MyDataPtr: PMyStructure;

    implementation

    {$R *.DFM}

    procedure TForm1.FormCreate(Sender: TObject);
    begin
    { Здесь ресурсы берутся из кучи. }
    New(MyDataPtr);
    MyDataPtr.Name := 'Fred';
    MyDataPtr.array[0] := 560;
    Dispose(MyDataPtr);
    end;

Вы также можете разместить объявление переменной в пределах класса:

type
TMyBigArray = array[1..100] of string

TForm1 = class(TForm)
public
{ Это объявление не повлияет на размер сегмента данных. }
MyBigArray: TMyBigArray;
end;

var
{ Это объявление увеличивает сегмент данных на 25,600 байт. }
MyOtherBigArray: TMyBigArray;

[000944]


Перекрытие виртуальных методов

Кто-нибудь знает, в чем разница между перекрытием (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. Перекрытые методы могут выполняться даже тогда, когда специфический экземпляр класса-предка является точной копией базового класса. "Замененные" методы могут выполняться только тогда, когда специфический экземпляр является "слепком" только этого класса.

[000297]


Вызов процедуры, имя которой содержится в переменной I

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

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.

[000307]


Delphi 1

Вызов процедуры, имя которой содержится в переменной II

Как мне использовать переменную типа string в качестве имени процедуры?

Никак. Тем не менее, вы могли бы создать 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 [000697]


Delphi 1

Динамические и виртуальные методы

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

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;

[000339]


Одной строкой

Использование SetBounds

Вы можете не задавать отдельно параметры Left, Top, Height и Width при использовании

SetBounds(l,t,w,h);

Например

Abc.Left = 25;

генерит

SetBounds(25,Abc.Top,Abc.Width,Abc.Height);

[000452]


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 [000643]


Delphi 1

Макро-процедуры

Каким образом мне можно использовать переменную типа String в качестве имени процедуры?

Если все процедуры, которые вы собираетесь вызывать имеют список с одними и теми же параметрами, (или все без параметров), то это не трудно. Для этого необходимо:

  1. процедурный тип, соответствующий вашей процедуре, например:

    Type
    TMacroProc = Procedure( param: Integer );

  2. массив, "подключающий" имена процедур к их адресам во время выполнения приложения:

    Type
    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 ),
    .....);

  3. интерпретатор функций, типа:

    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;

Peter Below [000691]


Одной строкой

Выполнение процедуры по адресу

var F:procedure(x,y:double);

@F := GetProcAddress( hDLL, 'SOMEPROC');
F(3,4);

Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).

- Peter Below [000811]


Создание объектных переменных

В новостной группе я несколько раз встречал вопросы подобного плана, указывающие на недостаток понимания работы экземпляра объекта. Я понимаю, что данный вопрос могут задать скорее новички в программировании, поэтому свой рассказ я начну издалека - с организации классов в Delphi. Я надеюсь, что моя "попытка" ликбеза по крайней мере объяснит суть предмета.

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

Когда вы объявляете переменную некоторого типа класса, как например...

var
MyVar: TMyClass;

....всех вас интересует: что делает в этом случае компилятор и достаточно ли распределено памяти, чтобы хранить указатель на экземпляр данного класса в куче памяти. Знайте же: вы не распределили память для данного класа, вы только что распределили память для указателя. Компилятор всегда инициализирует этот указатель в $FFFFFFFF, а это значит, что распределенный блок памяти пуст. Во всяком случае этого достаточно, чтобы сказать что указатель *не* указывает на верную "позицию" памяти и ваш класс *не* содержит никаких данных.

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

MyVar := TMyClass.Create;

Это действительно просто, поскольку метод конструктора Create класса TMyClass является классовым методом - он работает в классе, а не в отдельном объекте. Когда вы вызываете конструктор, Delphi распределяет память и возвращает значение указателя. Присмотритесь: не похоже ли это на вызов функции? Хорошо, если вы раньше не знали, что возвращалось при вызове, то теперь вы это знаете. Вызов TMyClass.Create возвращает указатель на объект типа TMyClass.

В конце концов то, что вам действительно нужно помнить, это...

  1. Объявление объектной переменной некоторого типа.
  2. Создание объекта вызовом метода конструктора класса.
  3. Использование объекта по назначению.
  4. Освобождение объекта.
==вырезано

procedure Example;
var
MyObj: TMyClass;   // класс, который вы создаете
MyList: TList;     // встроенный класс
begin
MyObj := TMyClass.Create;
// теперь MyObj содержит адрес блока памяти, распределенной для экземпляра вашего класса
MyList := TList.Create;
// Код для работы с MyList
....
здесь что-то делаем с объектом
....
MyList.Free;
// Ресурсы MyList удаляются из кучи
MyObj.Free;
// тоже самое для MyObj
end;

[000312]


Delphi 1

Создание объектов любого типа

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

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Grids, DBGrids, ExtCtrls, DBCtrls, DB, DBTables;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
public
NextTop : integer;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
NewObj : TControl;
NewClass: TPersistentClass;
begin
NewClass := FindClass(Edit1.Text);
NewObj :=
TControl(TComponentClass(NewClass).Create(Self));
NewObj.Parent := Self;
NewObj.Name := NewObj.ClassName+IntToStr(NextTop);
NewObj.Top := NextTop;
NextTop := NextTop+20;
end;

initialization
RegisterClasses([TButton,TEdit,TLabel]);
end.

[000483]


Delphi 1

Информация о 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.

[000506]


Delphi 1

Переназначения объектов

Существует ли возможность переключения набора данных, используемого 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. [000696]


Пример переменного количества параметров

program VarPar;

{ Простая программа, демонстрирующая пример использования переменного
числа параметров заданного типа в Delphi.

Создано в марте 1995, автор Hallvard Vassbotn
hallvard@falcon.no
}
uses WinCrt, SysUtils;

{ предопределения в System:
const
vtInteger  = 0;
vtBoolean  = 1;
vtChar     = 2;
vtExtended = 3;
vtString   = 4;
vtPointer  = 5;
vtPChar    = 6;
vtObject   = 7;
vtClass    = 8;

type
TVarRec = record
case Integer of
vtInteger:  (VInteger: Longint; VType: Byte);
vtBoolean:  (VBoolean: Boolean);
vtChar:     (VChar: Char);
vtExtended: (VExtended: PExtended);
vtString:   (VString: PString);
vtPointer:  (VPointer: Pointer);
vtPChar:    (VPChar: PChar);
vtObject:   (VObject: TObject);
vtClass:    (VClass: TClass);
end;
}
const
TypeNames : array [vtInteger..vtClass] of PChar  =
('Integer', 'Boolean', 'Char', 'Extended', 'String',
'Pointer', 'PChar', 'Object', 'Class');

{
Согласно on-line документации (поиск по слову TVarRec), массив параметров
array of const интерпретируется компилятором подобно массиву array of TVarRec.
Данный пример будет работать подобно тому, как если бы вы изменили
объявление TestMultiPar на:

procedure TestMultiPar(const Args: array of TVarRec);

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

Компилятор видит параметры и формирует массив непосредственно в
стеке. Для каждого элемента массива также устанавливается поле
VType с одной из предопределенных констант vtXXXX. Фактически
значение всегда передается в виде четыре байта информации. Для
типов Boolean и Char полезную информацию содержит только первый
байт.

Теперь вы можете писать все те же хорошие программы, но вдобавок
поддерживающие переменное количество параметров с проверкой типов!
}
function PtrToHex(P: pointer): string;
begin
Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4);
end;

procedure TestMultiPar(const Args: array of const);
var
ArgsTyped : array [0..$fff0 div sizeof(TVarRec)] of TVarRec absolute Args;
i         : integer;
begin
for i := Low(Args) to High(Args) do
with ArgsTyped[i] do
begin
Write('Args[', i, '] : ', TypeNames[VType], ' = ');
case VType of
vtInteger:  writeln(VInteger);
vtBoolean:  writeln(VBoolean);
vtChar:     writeln(VChar);
vtExtended: writeln(VExtended^:0:4);
vtString:   writeln(VString^);
vtPointer:  writeln(PtrToHex(VPointer));
vtPChar:    writeln(VPChar);
vtObject:   writeln(PtrToHex(Pointer(VObject)));
vtClass:    writeln(PtrToHex(Pointer(VClass)));
end;
end;
end;

var
MyObj : TObject;
begin
Writeln('Проверка выполнения функции с переменным количеством параметров и проверкой типов:');
MyObj := TObject.Create;
TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Здравствуй, мир!', true, 'X',
@ShortDayNames, TObject, MyObj]);
MyObj.Free;

{ Для того, чтобы обеспечить предварительную проверку типа при передаче параметров,
попробуйте следующее: }
writeln(Format('%d', ['привет']));
{ Переданный параметр не является ожидаемым типом. Строка формата '%d'
говорит о том, что параметр должен быть целой величиной, но вместо этого мы передаем
строку. Во время выполнения это вызовет исключительную ситуацию, и если вы не организовали
ловушку для объектов исключения, то Delphi выведет вам строку с описанием ошибки.
Использование функции C-типа sprintf в этом случае может привести к непредсказуемым
последствиям (читай: крах системы, GP и все что угодно) }
 end.

[000313]


Delphi 1

Переменное количество параметров любого типа

Вы можете определить список параметров процедуры как "Foo : ARRAY of const" и использовать почти ЛЮБОЙ тип параметра. Вот пример. Разместите на форме компоненты Memo и Button и добавьте строку "procedure Display(X : array of const);" в определения класса формы после комментария { Private Declarations }. Создайте функцию типа этой:

procedure TForm1.Display(X: array of const);
var I: Integer;
begin
Memo1.Clear;
for I := 0 to High(X) do with TVarRec(X[I]) do
WITH Memo1.Lines DO
case VType of
vtInteger : Add('Integer:'#9 + IntToStr(VInteger));
vtBoolean : if VBoolean then Add('Boolean:'#9'True'
else Add('Boolean:'#9'False');
vtChar    : Add('Char:'#9 + VChar);
vtExtended: Add('Float:'#9 + FloatToStr(VExtended^));
vtString  : Add('String:'#9 + VString^);
vtPointer : Add('Pointer:'#9 + Format('%p', [VPointer]));
vtPChar   : Add('PChar:'#9 + StrPas(VPChar));
vtObject  : Add('Object:'#9 + VObject.ClassName);
vtClass   : Add('Class:'#9 + VClass.ClassName);
end;
end;

Теперь в обработчике события кнопки OnClick вызываем процедуру Display и передаем ей "что попало". Числа, строки, PChar-ы, объекты! Например:

Display([42, 1.234, 'A', 'Васек Трубачев', Form1, TButton]);

Практичестки это программа с переменным числом параметров. Но самом деле параметр один, но он является массивом, содержащим переменное количество параметров различного типа. Потрясающе!

- Neil [000488]


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

Некоторые обработчики событий (типа TStringGrid OnDrawCell) получают параметры с именами Col и Row.

Возникает проблема при использовании следующего кода:

with Sender as TStringGrid do .....

где передаваемые параметры Col & Row теперь "прячутся" за пределами 'with'.

Kurt Barthelmess нашел как обойти эту проблему. Объявите:

var
CellCol: Longint absolute Col;
CellRow: Longint absolute Row;

Этот трюк позволяет обойтись без локальных переменных и работать с одноименными параметрами. [000992]


Как избежать использования неактуальных указателей

Я создал простой модуль и разработал несколько простых методов, помогающих избежать использования неактуальных (в оригинале было "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.

[000308]


Получение ссылки на экземпляр класса

...мне также понадобилось в подпрограмме получить ссылку на дочернее 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;

[000405]


Delphi 1

Работа метода 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 нет. [000430]


Delphi 1

Арифметика указателей

Вы можете рассказать об арифметике указателей в Delphi?

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

Основополагающая идея при занятиях арифметикой с указателем - указатель должен быть увеличен на значение корректного приращения. (Корректное приращение определяется размером объекта, на который показывает указатель. Например, 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^)) всегда возвращает величину корректного приращения (проще сказать, что это размер объекта - В.О.).

[000627]


Delphi 1

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

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

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

-------------------------PROPDEMO.PAS-----------------------------

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. [000474]


Delphi 1

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

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

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

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

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

Mike Scott
Mobius Ltd. [000525]


Демонстрация 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.

[000543]


Delphi 1

Свойство только для чтения во время выполнения программы

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

if csDesigning in ComponentState then
begin
... код, устанавливающий значение свойства ...
end;

Это позволяет в режиме выполнения приложения сделать свойство только для чтения. [000545]


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

В Инспекторе Объектов я пытаюсь получить раскрывающийся список для моего перечислимого типа...

Для этого вам необходимо создать собственный редактор свойства. Ниже приведен его простой пример:

type
TBaudRateProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
function GetValue: string; override;
procedure SetValue(const Value: string); override;
end;

...

type
TBaudRate=(br110,br300,br600,br1200,br2400,br4800,br9600,br14400,br19200,br38400,br56000,br128000,br256000);
const
BaudList : Array[TBaudRate] of string[7] =
('110','300','600','1200','2400','4800','9600','14400','19200','38400','56000','128000','256000');

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

procedure TBaudRateProperty.GetValues(Proc : TGetStrProc);
var
i : TBaudRate;
begin
for i:=Low(TBaudRate) to High(TBaudRate) do Proc(BaudList[i]);
end;

function TBaudRateProperty.GetValue: string;
begin
Result := BaudList[TBaudRate(GetOrdValue)];
end;

procedure TBaudRateProperty.SetValue(const Value: string);
var
i : TBaudRate;
begin
for i:=Low(TBaudRate) to High(TBaudRate) do
if BaudList[i]= Value then begin
SetOrdValue(integer(i));
EXIT;
end;
inherited SetValue(Value);
end;

Надеюсь это поможет.

Dan Miser
Med Data Systems, Inc. [000602]


Delphi 1

Поиск свойств

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

Хороший материал по этому вопросу вы найдете в typinfo.pas (каталог Docs); нижеследующий код заполнит компонент Memo именами свойств:

Using TypInfo;

procedure TForm1.Button1Click(Sender: TObject);
Var
PropList : pPropList;
J,I : Integer;
begin
Memo1.Lines.Clear;
getMem(PropList, sizeof(tPropList));
J := GetPropList(TypeInfo(tButton),tkProperties,PropList);
For I := 0 to J-1 do
Memo1.Lines.Add(PropList^[I]^.Name);
FreeMem(PropList, sizeof(tPropList));
end;

[000658]


Delphi 1

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

Если вы назвали свое свойство TableName, то полный цикл создания редактора свойств включает следующие шаги:

1. Опишите класс редактора свойства:

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;
begin
{ *********************************
здесь вы должны добавить свой код, чтобы с помощью
цикла обойти имена всех таблиц, включенных в список
***********************************
}
for I := 0 to ???? do
begin
TableName := ????[I];
Proc(TableName);
end;
end;

2. Затем вам необходимо зарегистрировать данный редактор свойства следующим образом (в вашей процедуре Register):

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

HTH, Dean [Classic Software] [000662]


Delphi 1

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

Я написал компонент-отладчик, выводящий в дереве все компоненты. Попробуйте этот код. Вызывайте функцию 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 [000753]


Свойство TStringList

Вам необходимо определять поле как TStrings, а не как TStringList - ловушка, в которую, подразумеваю, попадал не я один!

Следующий пример показывает подход, необходимый для создания свойства, имеющего тип TStringList:

private
FList: TStrings;

protected
procedure SetList(Value: TStrings);

published
property List: TStrings read FList write SetList;

constructor Txxxxx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FList := TStringList.Create;
end;

destructor Txxxxx.Destroy;
begin
FList.Free;
inherited Destroy;
end;

procedure Txxxxx.SetList(Value: TStrings);
begin
FList.Assign(Value);
end;

- Mike Orriss [000927]


Реализация собственного потока

Я хотел бы создать конструктор Load, загружающий список из потока...

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

Более важен тот факт, что вы можете использовать поток так, как вам это необходимо, исходя из вашей задачи и специфики. Я сделал работу потока похожую по стилю на BP7, где вначале идет ID класса. В каком-нибудь месте вам необходимо вызвать RegisterType( TYourClass, UniqueIDLikeBP7 ), после чего TYourClass готов к работе с потоками.

Вы наверняка обратили внимание, что я реализовал список зарегистрированных классов (регистратор), где с помощью ID легко можно найти классы, читающие и пишущие в поток в момент вызова конструктора Load соответствующего класса. Код простой и не требующий пояснений. Имейте в виду, что данный код можно использовать для организации передачи данных между существующим файловым потоком BP7 в объекты Delphi - я создал это для осуществления миграции с текущего приложения BP7 в Delphi и осуществления совместимости.

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

Успехов.

Mike Scott.

unit CompStrm;

interface

uses Classes ;

type
TCompatibleStream       = class ;

{ TStreamObject }

TStreamObject = class( TComponent )
constructor Load( S : TCompatibleStream ) ; virtual ; abstract ;
procedure Store( S : TCompatibleStream ) ; virtual ; abstract ;
function GetObjectType : word ; virtual ; abstract ;
end ;

TStreamObjectClass = class of TStreamObject ;

{ TCompatibleStream }

TCompatibleStream = class( TFileStream )
function  ReadString : string ;
procedure WriteString( var S : string ) ;
function  StrRead : PChar ;
procedure StrWrite( P : PChar ) ;
function  Get : TStreamObject ; virtual ;
procedure Put( AnObject : TStreamObject ) ; virtual ;
end ;

{ Register Type : используйте это для регистрации ваших объектов для
работы с потоками с тем же ID, который они имели в OWL }

procedure RegisterType( AClass : TStreamObjectClass ;
AnID   : word ) ;

implementation

uses SysUtils, Controls ;

var Registry : TList ;  { хранение ID объекта и информации о классе }

{ TClassInfo }

type
TClassInfo = class( TObject )
ClassType : TStreamObjectClass ;
ClassID   : word ;
constructor Create( AClassType : TStreamObjectClass ;
AClassID   : word ) ; virtual ;
end ;

constructor TClassInfo.Create( AClassType : TStreamObjectClass ;
AClassID   : word ) ;

var AnObject : TStreamObject ;

begin
if not Assigned( AClassType ) then
Raise EInvalidOperation.Create( 'Класс не инициализирован'
) ;
if not AClassType.InheritsFrom( TStreamObject ) then
Raise EInvalidOperation.Create( 'Класс ' + AClassType.ClassName +
' не является потомком TStreamObject'
) ;
ClassType := AClassType ;
ClassID := AClassID ;
end ;

{ функции поиска информации о классе }

function  FindClassInfo( AClass : TClass ) : TClassInfo ;

var i : integer ;

begin
for i := Registry.Count - 1 downto 0 do begin
Result := TClassInfo( Registry.Items[ i ] ) ;
if Result.ClassType = AClass then exit ;
end ;
Raise EInvalidOperation.Create( 'Класс ' + AClass.ClassName +
' не зарегистрирован для работы с потоком' ) ;
end ;

function  FindClassInfoByID( AClassID : word ) : TClassInfo ;

var i : integer ;
AName : string[ 31 ] ;

begin
for i := Registry.Count - 1 downto 0 do begin
Result := TClassInfo( Registry.Items[ i ] ) ;
AName := TClassInfo( Registry.Items[ i ] ).ClassType.ClassName ;
if Result.ClassID = AClassID then exit ;
end ;
Raise EInvalidOperation.Create( 'ID класса ' + IntToStr( AClassID ) +
' отсутствует в регистраторе
классов' ) ;
end ;

procedure RegisterType( AClass : TStreamObjectClass ;
AnID   : word ) ;

var i : integer ;

begin
{ смотрим, был ли класс уже зарегистрирован }
for i := Registry.Count - 1 downto 0 do
with TClassInfo( Registry[ i ] ) do if ClassType = AClass then
begin
if ClassID <> AnID then
Raise EInvalidOperation.Create( 'Класс ' + AClass.ClassName +
' уже зарегистрирован с ID ' +
IntToStr( ClassID ) ) ;
exit ;
end ;
Registry.Add( TClassInfo.Create( AClass, AnID ) ) ;
end ;

{ TCompatibleStream }

function  TCompatibleStream.ReadString : string ;

begin
ReadBuffer( Result[ 0 ], 1 ) ;
if byte( Result[ 0 ] ) > 0 then ReadBuffer( Result[ 1 ], byte( Result[ 0
] ) ) ;
end ;

procedure TCompatibleStream.WriteString( var S : string ) ;

begin
WriteBuffer( S[ 0 ], 1 ) ;
if Length( S ) > 0 then WriteBuffer( S[ 1 ], Length( S ) ) ;
end ;

function TCompatibleStream.StrRead : PChar ;

var L : Word ;
P : PChar ;

begin
ReadBuffer( L, SizeOf( Word ) ) ;
if L = 0 then StrRead := nil else
begin
P := StrAlloc( L + 1 ) ;
ReadBuffer( P[ 0 ], L ) ;
P[ L ] := #0 ;
StrRead := P ;
end ;
end ;

procedure TCompatibleStream.StrWrite( P : PChar ) ;

var L : Word ;

begin
if P = nil then L := 0 else L := StrLen( P ) ;
WriteBuffer( L, SizeOf( Word ) ) ;
if L > 0 then WriteBuffer( P[ 0 ], L ) ;
end;

function  TCompatibleStream.Get : TStreamObject ;

var AClassID : word ;

begin
{ читаем ID объекта, находим это в регистраторе и загружаем объект }
ReadBuffer( AClassID, sizeof( AClassID ) ) ;
Result := FindClassInfoByID( AClassID ).ClassType.Load( Self ) ;
end ;

procedure TCompatibleStream.Put( AnObject : TStreamObject ) ;

var AClassInfo : TClassInfo ;
ANotedPosition : longint ;
DoTruncate     : boolean ;

begin
{ получает объект из регистратора }
AClassInfo := FindClassInfo( AnObject.ClassType ) ;

{ запоминаем позицию в случае проблемы }
ANotedPosition := Position ;
try
{ пишем id класса и вызываем метод store }
WriteBuffer( AClassInfo.ClassID, sizeof( AClassInfo.ClassID ) ) ;
AnObject.Store( Self ) ;
except
{ откатываемся в предыдущую позицию и, если EOF, тогда truncate }
DoTruncate := Position = Size ;
Position := ANotedPosition ;
if DoTruncate then Write( ANotedPosition, 0 ) ;
Raise ;
end ;
end ;

{ выход из обработки, очистка регистратора }

procedure DoneCompStrm ; far ;

var i : integer ;

begin
{ освобождаем регистратор }
for i := Registry.Count - 1 downto 0 do TObject( Registry.Items[ i ]
).Free ;
Registry.Free ;
end ;

begin
Registry := TList.Create ;
AddExitProc( DoneCompStrm ) ;
end.

[000613]


Огромные числа

Данный модуль использует массив байт для предоставления БОЛЬШИХ чисел. Бинарно-хранимые числа заключены в массив, где первый элемент является Наименьшим Значимым Байтом (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.

{ Данный код был найден в файлах помощи Ллойда (Lloyd)! } [000154]


Некорректные вещественные значения

При использовании функции strtofloat для значения 1234.5544 я получаю что-то типа 1234.55440000000003, но ведь это неправильно!

Ничего здесь неправильного нет. Это просто погрешность чисел с плавающей точкой. Фактически источником ошибки является ошибка округления. Данная ошибка является следствием дефекта арифметики плавающей точки и того факта, что чаще всего десятичные дроби являются повторяющимися долями в двоичной системе счисления. Такие числа не могут представляться в конечном количестве битов. В связи с этим текстовое округление получается не всегда точным, т.к. большинство компьютеров подбирает последние цифры дробной части, исходя из ближайшего (с наименьшей разницей) эквивалента. Некоторые компьютеры не производят округления, а просто обрезают (выключают) последние биты, получая результирующую ошибку, правильно называемую ошибкой округления (в противоположность ошибке усечения, когда усекается расширение ряда). Для получения дополнительной информации обратитесь к Introduction to Numerical Methods (введение в числовые методы) авторов Peter A. Stark, Macmillian Company, 1970.

Из-за наличия ошибки сравнение двух чисел с плавающей точкой сводится к учету абсолютной или относительной погрешности.

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

IF ABS(CalculatedValue - TrueValue) < FuzzValue THEN ...

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

IF ABS( (CalculatedValue - TrueValue) / TrueValue ) <
AcceptableRelativeError THEN ...

, где AcceptableRelativeError определяет величину относительной погрешности (ну, и конечно, TrueValue <> 0.0).

Математеческий модуль Delphi 3 вычисляет относительную погрешность следующим образом (но оно не вынесено в секцию interface):

FUNCTION RelSmall(X, Y: Extended): Boolean;
{ Возвращаем Истину, если разница между X и Y незначительна }
CONST
C1: Double = 1E-15;
C2: Double = 1E-12;
BEGIN
Result := Abs(X) < (C1 + C2 * Abs(Y))
END;

[000162]


Delphi 2

Типы данных 16 & 32 бит

                 Delphi-16        Delphi-32

 SmallInt        16 бит           16 бит
 Integer         16 бит           32 бит
 LongInt         32 бит           32 бит

 Word            16 бит           16 бит
 Cardinal        16 бит           31 бит
[000677]


Одной строкой

Округление реальных типов

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

function RoundFloat(R: Extended; Decimals: Integer): Extended;
var
Factor: Extended;
begin
Factor := Int(Exp(Decimals * Ln(10)));
Result := Round(Factor * R) / Factor;
end;

-Steve Schafer [000829]


Delphi 2.0

Integer как SmallInt

Я перешел на Delphi 2.0 и у меня появилась проблема с типизированными файлами. У меня есть множество типизированных файлов с различными записями. Теперь, когда целое занимает 4 байта, определения всех моих записей должны быть изменены с расчетом на то, что вместо целого типа придется использовать тип SmallInts. Тем не менее, даже после такого изменения размер моих записей остается прежним...

Вам необходимо использовать модификатор "packed":

type
TMyRecType = packed record
...
end;

-Steve Schafer [000867]


Delphi 2.0

Величина SizeOf?

В Delphi 2.0 при использовании функции sizeof для моей записи:

f_format = record
format_name : string[8];
file_size  : smallint;
fields     : smallint;
end;

sizeof (format_name) возвращает 9
sizeof (file_size) возвращает 2
sizeof (fields) возвращает 2

sizeof(f_format) возвращает 14 ; Почему это не возвращает 13 ??????

Вам необходимо выключить опцию компилятора 'the Align Record Fields' (выравнивание полей записи).

- Dennis Passmore [000880]


Эквивалент Trim$(),Mid$() и др.

Решение 1

unit TrimStr;
{$B-}
{
Файл: TrimStr
Автор: Bob Swart [100434,2072]
Описание: программы для удаления конечных/начальных пробелов
и левых/правых частей строк (аналог Basic-функций).
Версия: 2.0

LTrim()    - Удаляем все пробелы в левой части строки
RTrim()    - Удаляем все пробелы в правой части строки
Trim()     - Удаляем все пробелы по краям строки
RightStr() - Возвращаем правую часть стоки заданной длины
LeftStr()  - Возвращаем левую часть стоки заданной длины
MidStr()   - Возвращаем центральную часть строки

}
interface
Const
Space = #$20;

function LTrim(Const Str: String): String;
function RTrim(Str: String): String;
function Trim(Str: String):  String;
function RightStr(Const Str: String; Size: Word): String;
function LeftStr(Const Str: String; Size: Word): String;
function MidStr(Const Str: String; Size: Word): String;

implementation

function LTrim(Const Str: String): String;
var len: Byte absolute Str;
i: Integer;
begin
i := 1;
while (i <= len) and (Str[i] = Space) do Inc(i);
LTrim := Copy(Str,i,len)
end {LTrim};

function RTrim(Str: String): String;
var len: Byte absolute Str;
begin
while (Str[len] = Space) do Dec(len);
RTrim := Str
end {RTrim};

function Trim(Str: String): String;
begin
Trim := LTrim(RTrim(Str))
end {Trim};

function RightStr(Const Str: String; Size: Word): String;
var len: Byte absolute Str;
begin
if Size > len then Size := len;
RightStr := Copy(Str,len-Size+1,Size)
end {RightStr};

function LeftStr(Const Str: String; Size: Word): String;
begin
LeftStr := Copy(Str,1,Size)
end {LeftStr};

function MidStr(Const Str: String; Size: Word): String;
var len: Byte absolute Str;
begin
if Size > len then Size := len;
MidStr := Copy(Str,((len - Size) div 2)+1,Size)
end {MidStr};
end.

Решение 2

Для Mid$ используйте Copy(S: string; start, length: byte): string;
С помощью команды Copy вы также можете осуществить операции Right$ и Left$, выполнив:
Copy(S, 1, Length) для left$ и
Copy(S, Start, 255) для right$
Примечание: Start и Length - байтовые позиции вашего "отправного пункта", вы можете получить их с помощью Pos().

Вот некоторые написанные мною функции, сослужившие хорошую службу. Сами вы можете начать с модификации функции trim(), например, разработать функции TrimRight$ и TrimLeft$, удаляющие пробелы с правой и левой части строк соответственно. Также вы можете создать функции, работающие как со паскалевскими строками, так и со стороками, заканчивающиеся нулем (терминатором).

const
BlackSpace = [#33..#126];

{
squish() возвращает строку со всеми белыми пробелами и с удаленными
повторяющимися апострофами.
}
 function squish(const Search: string): string;
var
Index: byte;
InString: boolean;
begin
InString:=False;
Result:='';
for Index:=1 to Length(Search) do
begin
if InString or (Search[Index] in BlackSpace) then
AppendStr(Result, Search[Index]);
InString:=((Search[Index] = '''') and (Search[Index - 1] <> '\'))
xor InString;
end;
end;

{
before() возвращает часть стоки, находящейся перед
первой найденной подстроки Find в строке Search. Если
Find не найдена, функция возвращает Search.
}
 function before(const Search, Find: string): string;
var
index: byte;
begin
index:=Pos(Find, Search);
if index = 0 then
Result:=Search
else
Result:=Copy(Search, 1, index - 1);
end;

{
after() возвращает часть строки, находящейся после
первой найденной подстроки Find в строке Search. Если
Find не найдена, функция возвращает NULL.
}
 function after(const Search, Find: string): string;
var
index: byte;
begin
index:=Pos(Find, Search);
if index = 0 then
Result:=''
else
Result:=Copy(Search, index + Length(Find), 255);
end;

{
RPos() возвращает первый символ последней найденной
подстроки Find в строке Search. Если Find не найдена,
функция возвращает 0. Подобна реверсированной Pos().
}
 function RPos(const Find, Search: string): byte;
var
FindPtr, SearchPtr, TempPtr: PChar;
begin
FindPtr:=StrAlloc(Length(Find)+1);
SearchPtr:=StrAlloc(Length(Search)+1);
StrPCopy(FindPtr,Find);
StrPCopy(SearchPtr,Search);
Result:=0;
repeat
TempPtr:=StrRScan(SearchPtr, FindPtr^);
if TempPtr <> nil then
if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then
begin
Result:=TempPtr - SearchPtr + 1;
TempPtr:=nil;
end
else
TempPtr:=#0;
until TempPtr = nil;
end;

{
inside() возвращает подстроку, вложенную между парой
подстрок Front ... Back.
}
 function inside(const Search, Front, Back: string): string;
var
Index, Len: byte;
begin
Index:=RPos(Front, before(Search, Back));
Len:=Pos(Back, Search);
if (Index > 0) and (Len > 0) then
Result:=Copy(Search, Index + 1, Len - (Index + 1))
else
Result:='';
end;

{
leftside() возвращает левую часть "отстатка" inside() или Search.
}
 function leftside(const Search, Front, Back: string): string;
begin
Result:=before(Search, Front + inside(Search, Front, Back) + Back);
end;

{
rightside() возвращает правую часть "остатка" inside() или Null.
}
 function rightside(const Search, Front, Back: string): string;
begin
Result:=after(Search, Front + inside(Search, Front, Back) + Back);
end;

{
trim() возвращает строку со всеми удаленными по краям белыми пробелами.
}
function trim(const Search: string): string;
var
Index: byte;
begin
Index:=1;
while (Index <= Length(Search)) and not (Search[Index] in BlackSpace) do
Index:=Index + 1;
Result:=Copy(Search, Index, 255);
Index:=Length(Result);
while (Index > 0) and not (Result[Index] in BlackSpace) do
Index:=Index - 1;
Result:=Copy(Result, 1, Index);
end;

[000249]


Фильтрованный поиск в строке

Есть множество задач, где необходимо использование так называемой "дикой карты", то есть поиск в строке по фильтру, когда в качестве поиска используется подстрока с символом "*" (звездочка). Например, если необходимо выяснить наличие подстроки 'St' с какими-либо символами перед ней, то в качестве параметра для поиска задается подстрока вида '*St'. Звездочка может присутствовать как в начале/конце подстроки, так и по обеим ее сторонам. Также при составлении фильтра вместо любого одиночного символа возможна подстановка знака вопроса.

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

{
Данная функция осуществляет сравнение двух строк. Первая строка
может быть любой, но она не должна содержать символов соответствия (* и ?).
Строка поиска (искомый образ) может содержать абсолютно любые символы.
Для примера: MatchStrings('David Stidolph','*St*') возвратит True.

Автор оригинального C-кода Sean Stanley
Автор портации на Delphi David Stidolph
}
 function MatchStrings(source, pattern: String): Boolean;
var
pSource: Array [0..255] of Char;
pPattern: Array [0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;
var
t: Integer;
begin
Result := StrScan(pattern,'*') <> nil;
if not Result then Result := StrScan(pattern,'?') <> nil;
end;

begin
if 0 = StrComp(pattern,'*') then
Result := True
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
Result := False
else if element^ = Chr(0) then
Result := True
else begin
case pattern^ of
'*': if MatchPattern(element,@pattern[1]) then
Result := True
else
Result := MatchPattern(@element[1],pattern);
'?': Result := MatchPattern(@element[1],@pattern[1]);
else
if element^ = pattern^ then
Result := MatchPattern(@element[1],@pattern[1])
else
Result := False;
end;
end;
end;

begin
StrPCopy(pSource,source);
StrPCopy(pPattern,pattern);
Result := MatchPattern(pSource,pPattern);
end;
[000250]


Разбивка строки на слова

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (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 ). [000251]


Замена подстрок

Кто-нибудь знает быстрый алгоритм поиска и замены всех найденных подстрок sub1 на sub2 в строке str?

Это должно работать:

function ReplaceSub(str, sub1, sub2: String): String;
var
aPos: Integer;
rslt: String;
begin
aPos := Pos(sub1, str);
rslt := '';
while (aPos <> 0) do begin
rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
Delete(str, 1, aPos + Length(sub1) - 1);
aPos := Pos(sub1, str);
end;
Result := rslt + str;
end;

Спасибо Сергею Шамайтис за исправление ошибки. [000252]


Как сделать, чтобы первая буква каждого слова в строке была в верхнем регистре?

function LowCase(ch : CHAR) : CHAR;
begin
case ch of
'A'..'Z' : LowCase := CHR (ORD(ch)+31);
else
LowCase := ch;
end;
end;

function Proper (source, separators : STRING) : STRING;
var
LastWasSeparator : BOOLEAN;
ndx              : INTEGER;
begin
LastWasSeparator := TRUE;
ndx := 1;
while (ndx<=Length(source)) do begin
if LastWasSeparator
then source[ndx] := UpCase(source[ndx])
else source[ndx] := LowCase(source[ndx]);
LastWasSeparator := Pos(source[ndx], separators)>0;
inc(ndx);
end;
Result := source;
end;

Можно так:

Function  TfrmLoadProtocolTable.ToMixCase(InString: String): String;
Var I: Integer;
Begin
Result := LowerCase(InString);
Result[1] := UpCase(Result[1]);
For I := 1 To Length(InString) - 1 Do Begin
If (Result[I] = ' ') Or (Result[I] = '''') Or (Result[I] = '"')
Or (Result[I] = '-') Or (Result[I] = '.')  Or (Result[I] = '(') Then
Result[I + 1] := UpCase(Result[I + 1]);
End;
End;

Примечание:

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

Попробуйте взамен это:

function proper(s:string):string;
var t:string;
i:integer;
newWord:boolean;
begin
if s='' then exit;
s:=lowercase(s);
t:=uppercase(s);
newWord:=true;
for i:=1 to length(s) do
begin
if newWord and (s[i] in ['a'..'z']) then
begin s[i]:=t[i]; newWord:=false; continue; end;
if s[i] in ['a'..'z',''''] then continue;
newWord:=true;
end;
result:=s;
end;

[000253]


Как определить, что два слова имеют схожее произношение?

{ Данный совет взят из файлов помощи Ллойда (Lloyd) }

Функция Soundex определяет схожесть звучания двух слов. Алгоритм Soundex опубликован в одной из статей журнала PC Magazine и предназначен для работы с английским языком (может кто-нибудь портирует для работы с нашим могучим? Пишите). Функции передается строка. Возвращаемое Soundex значение также имеет тип строки. Эта величина может сохраняться в базе данных или сравниваться с другим значением Soundex. Если два слова имеют одинаковое значение Soundex, можно предположить, что звучат они одинаково (более или менее).

Вы должны иметь в виду, что алгоритм Soundex игнорирует первую букву слова. Таким образом, "won" и "one" будут иметь различное значение Soundex, а "Won" и "Wunn" - одинаковое.

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

Function Soundex(OriginalWord: string): string;
var
Tempstring1, Tempstring2: string;
Count: integer;
begin
Tempstring1 := '';
Tempstring2 := '';
OriginalWord := Uppercase(OriginalWord); {Переводим исходное слово в верхний регистр}
Appendstr(Tempstring1, OriginalWord[1]); {Используем первую букву слова}
for Count := 2 to length(OriginalWord) do
{Назначаем числовое значение каждой букве, за исключением первой}

case OriginalWord[Count] of
'B','F','P','V': Appendstr(Tempstring1, '1');
'C','G','J','K','Q','S','X','Z': Appendstr(Tempstring1, '2');
'D','T': Appendstr(Tempstring1, '3');
'L': Appendstr(Tempstring1, '4');
'M','N': Appendstr(Tempstring1, '5');
'R': Appendstr(Tempstring1, '6');
{Все другие буквы, цифры и знаки пунктуации игнорируются}
end;
Appendstr(Tempstring2, OriginalWord[1]);
{Удаляем из результата все последовательно повторяющиеся цифры.}

for Count:=2 to length(Tempstring1) do
if Tempstring1[Count-1]<>Tempstring1[Count] then
Appendstr(Tempstring2,Tempstring1[Count]);
Soundex:=Tempstring2; {Это - значение soundex}
end;

SoundAlike - функция, проверяющая схожесть звучания двух слов. При схожести звучания она возвратит значение True и значение False в противном случае. Она демонстрирует пример использования функции Soundex.

Function SoundAlike(Word1, Word2: string): boolean;
begin
if (Word1 = '') and (Word2 = '') then result := True
else
if (Word1 = '') or (Word2 = '') then result := False
else
if (Soundex(Word1) = Soundex(Word2)) then result := True
else result := False;
end;

Дополнение

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

Пример:

    Андрей vs. Андрей - 6
    ндрей vs. Андрей - 5
    Анрей vs. Андрей - 5
    Андрей vs. Александр - 4
    Андрей vs. Иннокентий - 2
    АнXрей vs. Андрей - 3, но в то же время с другими словами результат
будет на уровне 0..2
Andrew V. Fionik. [000254]


Удаление ненужных подстрок из строки

procedure RemoveInvalid(what, where: string): string;
// what - удаляемая подстрока, where - обрабатываемая строка
var
tstr: string;
begin
tstr:=where;
while pos(what, tstr)>0 do
tstr:=copy(tstr,1,pos(what,tstr)-1) +
copy(tstr,pos(what,tstr)+length(tstr),length(tstr));
Result:=tstr;
end;

Применение:

NewStr:=RemoveInvalid('<брак>','Этот <брак> в моей строке, и я хочу
удалить из нее этот <брак>');

Другое решение:

Используйте стандартную функцию Pascal DELETE...
Пользуясь тем же примером, вы можете сделать так....

Target:='<брак>';
While POS(Target,string)>0 do
begin
P := POS(Target,string);
DELETE(string,P,Length(Target));
end;

[000257]


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

Strs : Тоже самое, что и Str (для integer/longint), но в более функциональной форме, что позволяет сделать преобразование числа в строку более простым.

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

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

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

Function Strs (I:longint) : string ;

Var X : string[16] ;

begin
STR (I,X) ;
Strs := X ;
end ;

Пример:

s :='пользователь=Вася';
Text := After ('=',s);
Text := Text+fp(Text<>'',' есть #Неизвестный ') + Before ('=',s);

Text будет содержать 'Вася есть пользователь'
Если s содержало бы только 'пользователь' или 'пользователь=' то Text был бы 'Неизвестный пользователь'

Function Before ( Src:string ; Var S:string ) : string ;

Var F : Word ;

begin
F := POS (Src,S) ;
if F=0 then
Before := S
else
Before := COPY(S,1,F-1) ;
end ;

Function After ( Src:string ; Var S:string ) : string ;

Var F : Word ;

begin
F := POS (Src,S) ;
if F=0 then
After := ''
else
After := COPY(S,F+length(src),length(s)) ;
end ;

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

Пример 1:

MyText := strs(N)+' компьютер'+FP (N>1,'ы') ;

Пример 2:

if Nargs<>4 then
Msg :='Имеется '+FP(Nargs>4,'много#несколько')+' аргументов.');

const MY_SEP : Char = '#';

Function FP ( B : Boolean ; S:string ) : string ;

begin
if POS (MY_SEP,S)>0 then
if B then
S := Before (MY_SEP,S)
else
S := After (MY_SEP,S)
else
if not B then S := '' ;
FP := S ;
end ;

[000260]


Функция наполнения строки

К примеру, назовем функцию "spcs" и создадим следующий код:

function Spcs(num : byte) : string;
var tmp : string;
begin
fillchar(tmp, num+1, ' ');  {инициализация всей строки пробелами}
tmp[0] := chr(num);         {устанавливаем длину строки с пробелами}
result := tmp;
end;

Теперь достаточно написать

Edit1.Text := SurName + spcs(10) + FirstName.

[000447]


Delphi 1

Паскалевский эквивалент StrTok

function  NextToken( P : PChar ; Divider : PChar ) : PChar ;

const next : PChar = nil ;

begin
if P = nil then P := next ;
if P <> nil then begin
next := StrPos( P, Divider ) ;
if next <> nil then begin
next^ := #0 ;
next := @next[ StrLen( Divider ) ] ;
end ;
end ;
NextToken := P ;
end ;

- Mike Scott. [000758]


Delphi 1

Строка как объект StringList

Вы можете создать простой объект, инкапсулирующий строку:

Type
tStrObj = Class ( tObject )
Data : String;
End;

Затем вы могли бы делать следующее:

With ListBox1 Do
Begin
AddObject(Table1.Fields[0].AsString, TStrObject.Create );

{ Объект добавляется в конец списка, поэтому для его чтения установите индекс равным Count-1 }
TStrObj(Objects[Count-1]).Data := Table1.Fields[1].AsString);
End;

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

{ для удаления элемента с Index I}
With ListBox1 Do
Begin
Objects[I].Free;
Delete ( I );
End;

- Robert Wittig [000760]


Delphi 1

Строковая нумерация

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

ClassInfo - метод класса, поэтому вы можете его использовать вместо экземпляра объекта. Но прежде вам необходимо заиметь этот класс, иначе никакого RTTI...

{$Z+}
type
TMyEnum = (one, two, three);
TEnumClass = Class( TComponent )
private
FEnum: TMYEnum;
published
property Enum: TMyEnum read FEnum;
End;

procedure TForm1.BtnTestClick(Sender: TObject);
Var
pOneName: PString;
PropInfo: PPropInfo;
begin
PropInfo := GetPropInfo( TEnumClass.ClassInfo, 'ENUM' );
pOneName := GetEnumName( PropInfo^.PropType, Ord(One));
If pOneName <> Nil Then
ShowMessage( pOneName^)
Else
ShowMessage('Nil!');
end;

Черная магия <G>!

- Peter Below [000761]


Одной строкой

String и PChar

Den is Com советует:

В 32-битном Дельфи String и PChar это одно и тоже. Старый String из Дельфи 1 - это shortstring. Используйте прямое преобразование PChar(String_variable) - это сохранит память при использовании функций WIN32. [000812]


Delphi 1

Не работает функция Writeln

Для того, чтобы Delphi "увидела" функцию Writeln, включите WinCrt в список используемых модулей. [000321]


Delphi 1

Определение графики в WinTypes/Graphics

Модули WinTypes и Graphics имеют два различных определения TBitmap. Вы можете проверить по ссылкам (WinTypes.TBitmap и Graphics.TBitmap), чтобы быть уверенным в том, что вы выбрали именно то, что вам нужно.

Поскольку в Delphi вы захотите воспользоваться только одним классом, установите WinTypes прежде, чем модуль Graphics устранит некоторые проблемы. [000324]


Delphi 1

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

Компонент во время проектирования может знать имена текущих модулей и имя проекта. Все это можно получить с помощью 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 [000820]


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

Галимарзанов Фанис советует:

TForm имеет свойство ActiveControl. Очень часто требуется для нескольких DBGrid на форме обеспечить обработку через общий TSpeedBar. Посмотрите, как описан код обработки события Click кнопки SpeedBar - циклический просмотр на совпадение ActiveControl.Name с именем Grid.

procedure TfmAb.insClick(Sender: TObject); // кнопка "Новая запись"
begin
if ActiveControl.Name='grFio' then EditAbProps(true) else
if ActiveControl.Name='grAbLgot' then EditAbLgot(grAbLgot.DataSource,true)
else
............
end;

или

procedure TfmAbDelClick(Sender: TObject); // кнопка "Удалить запись"
begin
if ActiveControl.Name='grFio' then DelRec(dm.taAb) else
if ActiveControl.Name='grAbLgot' then DelRec(dm.taAbLgot) else
............
end;

[000794]


Прерывание цикла FOR

Александр Пронин пишет:

Совершенно недавно (12 апреля 2000 г.) я прочел в рассылке RU.DELPHI вопрос как остановить цикл FOR человеческими методами ....

На что ответил (привожу пример pas - файла):

unit Unit1;

interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
k : integer;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
i : longint;
begin
i:=0;
k:=0;

for i:=0 to 500000 do
begin
Application.ProcessMessages; //"Волшебное слово" из-за чего все
//работат как надо :)
if k >0 then exit;
label1.caption := inttostr(i);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);

begin
k:=1; //
end;

end.

[000810]


Delphi 2

Новые возможности языка в Delphi 2

Новые возможности языка в Delphi 2.0 (32-бит).

В Delphi 2.0 определено несколько новых типов данных, использующих возможности, доступные в Windows 95. В Delphi 2.0 также были изменены несколько типов данных для того, чтобы воспользоваться преимуществами 32-битной среды.

Новые типы данных включают в себя:

   Character type (символьный тип)
   String type    (строковый тип)
   Variant type   (вариантный тип)
   Currency type  (денежный тип)
Измененные типы данных:
   Integer
   Cardinal
Дополнительный синтаксис:

секция модуля finalization

Новые типы данных

Character type (символьный тип)

Delphi 2.0 вводит новый, "широкий" тип символов для поддержки Unicode. Delphi 1.0 рассматривал символы в виде 8-битных величин типа Char.

Вот стандартные типы, представляющие символы в Delphi 2.0:

   ANSIChar - Стандартный 8-битный ANSI-символ, эквивалент типа Char в
                     предшествующих версиях Delphi.

   WideChar - 16-битный символ, представляющий символ Unicode.
                     Если старший байт является нулем, младший байт
                    содержит символ ANSI.

       Char - тип по умолчанию, Char является эквивалентом ANSIChar.
                 Char работает также, как и зависящий от реализации целочисленный
                 тир Integer, который эквивалентен SmallInt в 16-битной версии
                 Delphi и LongInt в 32-битной версии Delphi.
                 В Delphi 2.0 Char по умолчанию является 8-битной величиной.
Символьные типы-указатели:
              Тип-указатель 	    Символьный тип
              -------------         --------------
              PANSIChar		    ANSIChar
              PWideChar	            WideChar
              PChar		    Char
Семантика всех символьных типов-указателей идентична. Единственная изменяющаяся вещь - размер символа, на который ссылается указатель.

String Type (строковый тип)

Delphi 2.0 поддерживает строки практически неограниченной длины, в отличие от строк длиной в 255 символов, поддерживаемой ранее. Новая директива компилятора, $H, позволяет задать для ключевого слова "string" новую, или старую длину строки. Состояние по умолчанию $H, т.е. $H+, используется строка неограниченной длины. Все компоненты Delphi 2.0 используют новый тип строки с неограниченной длиной.

Вот новые строковые типы:

   ShortString - Нумерованная строка с максимальной длиной 255
                       символов. Эквивалент типа String в
                       Delphi 1.0. Каждый элемент имееет тип ANSIChar.

    AnsiString - Строка нового стиля с переменной длиной, также называемая "длинной строкой."
                       Каждый элемент имееет тип ANSIChar.

           string - Или короткая строка, или строка ANSI,
                      в зависимости от значения директивы компилятора $H.

 WideString - Длинная строка, каждый элемент имеет тип WideChar.
Вот вопросы совместимости.

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

Операции с  	       Эквивалент для
короткой строкой       длинной строки	   Пояснение
----------------       --------------      ---------
PString type           string	           Все длинные строки распределяются динамически, поэтому
                                           PString излишен и требует более трудного программирования.
S[0] := L	       SetLength(S,L)      Поскольку длинные строки распределяются динамически,
                       SetString(S,P,L)    то для распределения необходимого количества памяти
                                           вы должны вызывать процедуру SetLength.
StrPCopy               StrPCopy(Buffer,
(Buffer, S)	       PChar(S))	   Вы можете осуществить приведение типа длинной строки к
                                           строке с терминирующим нулем. Адрес длинной строки
                                           совпадает с адресом ее первого символа, а ее
                                           длина рассчитывается до терминирующего нуля.
S := StrPas(P)	       S := P	           Длинные строки могут автоматически копироваться из
                                           строк с терминирующим нулем.
Длинные строки не могут передаваться в качестве параметров типа "открытых строк" или переменных параметров короткой строки (var-параметры).

Вариантный тип

Delphi 2.0 вводит понятие вариантного типа (variant type), дающее вам мощный и гибкий инструмент для динамического изменения типа переменной. Это может оказаться полезным при работе с OLE-автоматизацией или определенных типах операциях с базой данных, где тип параметра, передаваемого сервером приложению Delphi, заранее неизвестен.

Вариантный тип является 16-битной структурой, хранящей информацию о типе вместе с самой величиной, которая, в свою очередь, может представлять из себя строку, целое или значение с плавающей точкой. Компилятор признает стандартный идентификатор типа Variant как объявление variant.

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

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

Денежный (Currency) тип

Delphi 2.0 вводит понятие нового, денежного (Currency) типа, являющегося типом с плавающей точкой и разработанного специально для работы с большими значениями, имеющими большую точностью. Данный тип для присвоения совместим со всеми типами, поддерживающими плавающую точку (и вариантным типом), но в действительности он хранится в виде 64-битного целого значения, очень похожего на тип Comp.

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

Измененные типы данных

Зависимые от реализации типы Integer и Cardinal в Delphi 2.0 представлены 32-битными величинами, в Delphi 1.0 они были 16-битными. Если вам необходимо объявить данные 16-битного целого типа, используйте типы SmallInt и Word.

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

Вы можете включить в модуль дополнительную секцию finalization. Finalization - аналог initialization (инициализация), и срабатывает при завершении приложения. Вы можете думать о секции finalization как об "коде выхода" из модуля ("код покидания модуля"). Секция finalization перекрывает соответствующие вызовы ExitProc и AddExitProc в Delphi 1.0.

Секция finalization начинается с зарезервированного ключевого слова finalization. Секция finalization должна располагаться после секции initialization, но до конечного end.

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

Секции Finalization выполняются в порядке, обратном секциям initialized. Например, если ваше приложение инициализирует модули в порядке A, B, и C, то при завершении приложения порядок выполнения секций finalization таков: модуль C, B, и A.

Схема модуля может быть похожей на эту:

unit UnitName;
interface
{ список uses; опция }
...
implementation
{ список uses; опция }
...
initialization { опция }
...
finalization { опция }
...
end.

[000856]


Поиск класса

Могу ли я во время выполнения приложения определить, существует ли класс с именем Tlog?

Используйте в модуле TLog RegisterClass( TLog ) или потомка TLog, затем FindClass( 'TLog' ) или FindClass( 'TLogSubclass' ) для получения ссылки на класс в вызывающем модуле, позволяя тем самым пользоваться объектами данного класса. Вы также могли бы добавить классовый метод, возвращающий существующий экземпляр или NIL, или который создает и возвращает новый экземпляр при отсутствии текущего.

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

Тем не менее, я считаю не лучшим решением технологию поиска класса по его имени. Вот что предлагаю я:

unit LogUnit ;

interface

type
TLog = class
public
constructor Create ;
procedure LogMessage( const Message : string ) ; virtual ; abstract ;
end ;

var Log : TLog ;

implementation

constructor TLog.Create ;
begin
Log := Self ;
end ;

procedure TidyUp ; far ;
begin
Log.Free ;
end ;

initialization
AddExitProc( TidyUp ) ;
end.

unit LogImpl ;

interface

implementation

uses Log ;

type
TLogImplementation = class( TLog )
public
procedure LogMessage( const Message : string ) ; override ;
end ;

procedure TLogImplementation.LogMessage( const Message : string ) ;
begin
{ записываем сообщение в журнальный файл }
end ;

initialization
TLogImplementation.Create ;
end.

Обратите внимание на то, что здесь используются "скрытые" данные - класс TLogImplementation объявлен внутри секции реализации модуля LogImpl, поэтому никакой другой модуль их не видит. Фактически, интерфейсная часть полностью пустая! Вы можете протестировать это, изучив Log и увидев NIL в самом начале.

Кроме того, вы могли бы иметь ничего не делающий TLog.LogMessage. Затем вы могли бы создать экземпляр TLog в секции инициализации модуля LogUnit.pas, и освобождать его перед созданием экземпляра TLogImplementation в LogImpl.pas. Таким образом, для подключения к приложению класса, нужно просто добавить к проекту модуль LogImpl.

- Mike Scott [000991]


Редактор свойства 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 [000995]


Создание db-файла во время работы приложения

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;

Дополнение

Читатель VS пишет:

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

Простейший способ – использовать SQL запрос. Таблицы можно создавать с индексом и без индекса.
Небольшой пример:

…
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;

[000027]


Формат файла 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" несомненно дало огромный эффект. [000343]


Динамическое создание полей I

Как во время работы приложения динамически создавать поля в наборе данных?

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;

Надеюсь это поможет.
Marco Romanini (SysOp)
Delphi Tech Support [000416]


Динамическое создание полей II

Как мне определить на лету другое поле подобно команде "Define" в редакторе полей (Fields Editor)? (Калькулируемое поле, другими словами?)

Следующий код создаст полный набор 'default' TField для TTable и добавит затем калькулируемое поле:

procedure TForm1.Button1Click(Sender: TObject);
var
f : TField;
i : integer;
begin
Table1.Close;
for i := 0 to Table1.FieldDefs.Count - 1 do
Table1.FieldDefs.Items[i].CreateField(Table1);
f := TStringField.Create(Table1);
f.Name := 'Table1CalcField';
f.FieldName := 'CalcField';
f.DisplayLabel := 'CalcField';
f.Calculated := True;
f.DataSet := Table1;
Table1.Open;
end;

...следующий пример создаст два новых TField в TTable, 'базируясь' на TField, определенных в режиме редактирования. Одно из новых полей калькулируемое, другое нет:

procedure TForm1.Button1Click(Sender: TObject);
var
f1, f2 : TField;
begin
Table1.Close;
f1 := TStringField.Create(Table1);
f1.Name := 'Table1CalcField';
f1.FieldName := 'CalcField';
f1.DisplayLabel := 'CalcField';
f1.Calculated := True;
f1.DataSet := Table1;
f2 := TFloatField.Create(Table1);
f2.Name := 'Table1Population';
f2.FieldName := 'Population';
f2.DisplayLabel := 'Population';
f2.DataSet := Table1;
Table1.Open;
end;

Eryk [000702]


Delphi 1

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

Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью 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.

[000463]


Создание кросс-таблицы

Вы можете создать их в 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;

Michael Lant [000484]


Delphi 1

Создание/удаление полей во время выполнения программы

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 и активный в настоящий момент, перед вызовом данного метода должен быть закрыт и впоследствии вновь активирован. [000532]


Delphi 1

Кросс-таблица через 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-движков сохранят результат в кэшовой памяти, так что скорость выполнения запроса весьма велика.

- John Crowley [000766]


Создание уникального табличного индекса

Вот что пишет Галимарзанов Фанис:

Очень часто требуется решить проблему уникальности индекса для таблиц - не всегда можно дополнять ключ меткой времени. Для этого можно использовать метод TTable.OnPostError.
При создании таблицы добавляем поле Ax типа ftInteger или ftSmallInt, которое будет замыкать ключевые поля. К примеру, необходимо создать таблицу платежей абонентов, в которой могут существовать несколько платежей, проведенных в один день.

abKod         : код абонента, входит в первичный ключ
Data          : дата платежа, входит в первичный ключ
Ax            : дополнительное поле, входит в первичный ключ и замыкает
его
TypeOpl       : тип оплаты
Summ          : сумма платежа
В примере уникальность ключа можно обеспечить за счет поля Data, но это достигается за счет включения кода вида
taOplData.Value:=taOplData.Value+Time;

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

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

Const
eKeyViol = 9729;  // код ошибки BDE - нарушение уникальности записи

procedure TForm1.Table1PostError(DataSet: TDataSet; E: EDatabaseError;
var Action: TDataAction);
begin
if (E is EDBEngineError) then // здесь обычный код распознавания кода
ошибки
if (E as EDBEngineError).Errors[0].Errorcode = eKeyViol then  begin
DataSet.FieldByName('Ax').Value:=DataSet.FieldByName('Ax').Value+1;
// Увеличиваем значение поля Ax и повторяем попытку Post
Action:=daRetry; // повторить операцию сохранения
end;
end;

Этот метод я применяю во всех приложениях. Кстати - для начинающих, пишем код метода OnPostError только для одной таблицы, для остальных. имеющих поле Ах, - с помощью инспектора свойств-событий назначаем для события OnPostError ссылку на метод первой таблицы, для которой мы писали код. [000792]


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

Данная проблема возникает из-за того, что BDE вначале запрашивает базу данных для получения информации о таблице, прежде чем он начнет с ней работать. Как только появляется информация о таблице, она кэшируется и обращение к таблице во время всего сеанса (пока TDatabase.Connection имеет значение True) происходит практически мгновенно. Для того, чтобы использовать кэшируемую информацию и при последующем запуске приложения, в конфигурации BDE найдите необходимый псевдоним и установите BDE CACHE = TRUE и BDE CACHE DIR = 'C:\temp' или любой другой удобный каталог.

ПРИМЕЧАНИЕ:
При любом изменении структуры таблицы Вам придется удалять кэш вручную. Имя файла, в котором хранится кэш, Вы можете узнать, посмотрев в любом текстовом редакторе файл SCache.INI. [000028]


Delphi 1

Доступ к файлам Paradox через BDE в сети Lantastic Network

Я имею BDE, сеть Lantastic и работающие с ними Delphi-приложения. На одной машине проблем не было, зато другие с BDE работать не смогли.

Возможные варианты:

  • Первая машина имела BDE от фактической Database Engine, а не из Delphi.
  • В секции [386Enh] файла system.ini была строка

    network=lantasti.386

    вместо правильной

    network=*vnetbios,lantasti.386

РЕШЕНИЕ ПРОБЛЕМЫ LANTASTIC 6.0 + BDE

===========================================

Проблема: Доступ к файлам Paradox через BDE в сети Lantastic Network.

Должно быть проблема в файле LPICALLW.DLL. Когда я его удалил, функциональность сети восстановились!!! Чтобы найти файл, загрузитесь без autoexec.bat. Я нашел его в директории lantasti. Если вы не установили к нему путь типа path=c:\dos, то при загрузке LPICALLW.DLL найден не будет... После этого система выведет диалоговое окно с сообщением о неудачной попытке найти файл LPICALLW.DLL. Нажмите OK и вы сможете, используя Borland DELPHI, PARADOX или D-BASE, иметь доступ к файлам Paradox !!!!

LANTNET.DRV загружает LPICALLW.DLL.
LPICALLW.DLL делает массу вызовов. Похоже на то, что это оболочка для всех сетевых вызовов. Может я и ошибаюсь насчет этого файла и дурит все-же BDE. Я думаю что это BDE.

Когда вы удаляете LPICALLW.DLL, вы не можете загрузить WNET.EXE в Windows. Но при это вы имеете доступ к файлам Paradox.

========================================

У меня была эта проблема, и я думаю что нашел причину.
Я работал под Lantastic и при инициализации базы данных имел ошибку сети.
Я выключил 32-битный доступ к файлам, после чего все заработало. На всю работу у меня ушло 3 часа. [000418]


Delphi 1

Импорт CSV ASCII

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

Dave

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.

[000419]


Delphi 1

Имя пользователя 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 ;

[000420]


Delphi 1

Загрузка изображений в 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;

[000538]


Delphi 1

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 [000551]


Blob-поля, потоки, компрессия...

Приветствую Вас, Валентин!

*** skip (личная переписка) ***.

В последней версии "Советов" я нашел рекомендацию по сохранению текста из TStrings в поле BLOB таблицы базы данных (однако на мой взгляд приведенный код делает обратное - т.е. считывает содержимое поля BLOB в 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 указывающий на каталог с этой таблицей.

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

  1. Создайте новый проэкт;
  2. Скопируйте выделенную красным цветом часть файла Main.dfm в буфер обмена;
  3. Сделайте активной вновь созданную форму и вставте в нее содержимое буфера;
  4. Измените свойства самой формы в соответствии с нижеприведенным описанием.
Файл 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.

С наилучшими пожеланиями
Сергей Лагонский. [000565]


Delphi 1

Изображения и 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-поле. Три самых простых метода включают в себя:

  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;

[000593]


Delphi 1

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е может возникнуть и-за того, что при неправильном определении в значения данных могут попасть данные другого, соседнего поля. При таком стечение обстоятельств трансляция данных прерывается, и в файле схемы требуется установка правильной длины поля и его отступа.

[000641]


Delphi 1

Извлечение текста из 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 [000693]


Delphi 1

Общий доступ к данным с DBD & Pdox

Я обнаружил, что открытый Data Desktop, даже без открытых объектов, может создавать "помехи". Также мудрит открытая сессия Delphi, если вы запускаете собранное приложение вне IDE. Я допускаю, что если вы закрываете все объекты под DD, конфигурация BDE быстро себя не очистит. Наверное мне следовало бы запустить мое приложение пару недель спустя, но я реально предполагаю, что множество сеансов Paradox блокируют бедный BDE.

Пожалуйста запустите утилиту BDE Config, поставляемую с Delphi и с PdoxWin. Перейдите на страницу SYSTEM и проверьте, установлен ли параметр LOCAL SHARE. Если вы хотите, что несколько приложений имели доступ к данным Paradox, LOCAL SHARE должен быть установлен в TRUE (и должны быть загружены SHARE или VCACHE).

При этом вы должны принимать во внимание, что если вы хотите, чтобы "LOCAL SHARE = TRUE" все время работал правильно и надежно, вы должны также определить уникальные индивидуальные каталоги для всех приложений, использующих BDE для доступа к таблицам Paradox. В противном случае, "поведение по умолчанию" заставит BDE использовать текущий рабочий каталог как частный. И, как вы все догадываетесь, Pdox блокирует данный каталог, считая его "частной собственностью" и не допуская к табличкам остальных соперников . . . то-то, а вы говорите "блокируют бедный BDE".

Mark Ostroff [000737]


Delphi 1

Получение Memo с помощью Query

Получение Memo-значения в область Edit без использования Memo-поля.

  • Разместите на вашей форме объект Query (Query1)
  • Разместите на вашей форме объект Edit (Edit1)
  • Разместите на вашей форме объект Button (Button1)
  • Дважды щелкните на Query и добавьте поле Memo. (Biolife.db использует текстовое поле)
  • Установите свойство Query1 SQL следующим образом: Select * from Biolife
  • Установите свойство Query1 Active в True
  • Добавьте следующий код в обработчик события кнопки Button1 OnClick:

    procedure TForm1.Button1Click(Sender: TObject);
    var
    bs : TBlobStream;
    p  : array [0..50] of char;
    begin
    FillChar(p, SizeOf(p), #0);
    bs:= TBlobStream.Create(Query1Notes, bmRead);
    try
    bs.Read(p,50);
    finally
    bs.Free;
    end;
    Edit1.Text:=StrPas(p);
    end;

[000939]


Извлечение изображения из BLOB-поля

Тема: Извлечение изображения из 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;

[000940]


Данные индекса таблицы

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

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

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

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

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

Каждая индексная запись (index record) содержит информацию об индексе. Процесс получения массива записей, содержащих информацию отдельно о каждом индексе, достаточно прост в реализации.

Свойство IndexDefs компонента TTable содержит информацию об индексах таблицы, используемой компонентом TTable, TQuery или TStoredProc. Само свойство IndexDefs в свою очередь также имеет различные свойства, содержащие специфическую информацию об извлекаемых индексах. Объект IndexDefs содержит два свойства:

    Count: type Integer;
доступно только во время выполнения программы и имеет флаг только для чтения; указывает на количество элементов в свойстве Items (например, количество индексов в таблице).
  Items: type TIndexDef;
доступно только во время выполнения программы и имеет флаг только для чтения; массив объектов TIndexDef, каждый объект описывает один индекс таблицы.

Свойство Count объекта IndexDefs является основой для создания счетчика цикла, в теле которого с помощью элементов свойства Items извлекается информация о каждом индексе таблицы. Каждый объект IndexDef, содержащийся в свойстве Items, состоит из множества свойств, описывающих характеристики каждого индекса в отдельности. Все свойства объекта IndexDef доступны только во время выполнения программы и имеют флаг "только для чтения". Вот эти свойства:

  Expression: type String; содержит выражение, использующееся
                           для dBASE multi-field индексов
                           (индексов для нескольких полей).
  Fields:     type String; содержит поле или несколько полей,
                           на основе которых создан индекс.
  Name:       type String; имя индекса.
  Options:    type TIndexOptions; характеристики индекса
                           (ixPrimary,  ixUnique и др.).
Перед получением любой информации об индексе (Count или Items) необходимо вызвать метод Update объекта IndexDefs. Это обновляет (или инициализирует) набор индексов для объектов IndexDef.

Примеры

Вот пример простого For-цикла, использующего в качестве счетчика свойство Count объекта IndexDefs, и извлекающего имя каждого индекса (если какой-либо существует) таблицы, представленной компонентом TTable с именем Table1:

procedure TForm1.ListBtnClick(Sender: TObject);
var
i: Integer;
begin
ListBox1.Items.Clear;
with Table1 do begin
if IndexDefs.Count > 0 then begin
for i := 0 to IndexDefs.Count - 1 do
ListBox1.Items.Add(IndexDefs.Items[i].Name)
end;
end;
end;

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

procedure TForm1.FormShow(Sender: TObject);
var
i: Integer;
S: String;
begin
with Table1 do begin
Open;
{Обновляем объект IndexDefs}
IndexDefs.Update;
if IndexDefs.Count > 0 then begin
{Устанавливаем колонки и строки сетки для соответствия элементам IndexDefs}
SG1.ColCount := 4;
SG1.RowCount := IndexDefs.Count + 1;
{Устанавливаем заголовки колонок сетки согласно именам свойств TIndexDef}
SG1.Cells[0, 0] := 'Name';
SG1.ColWidths[0] := 200;
SG1.Cells[1, 0] := 'Fields';
SG1.ColWidths[1] := 200;
SG1.Cells[2, 0] := 'Expression';
SG1.ColWidths[2] := 200;
SG1.Cells[3, 0] := 'Options';
SG1.ColWidths[3] := 300;
{Цикл с опросом IndexDefs.Items}
for i := 0 to IndexDefs.Count - 1 do begin
{Заполняем ячейки сетки в текущей колонке}
SG1.Cells[0, i + 1] := IndexDefs.Items[i].Name;
SG1.Cells[1, i + 1] := IndexDefs.Items[i].Fields;
SG1.Cells[2, i + 1] := IndexDefs.Items[i].Expression;
if ixPrimary in IndexDefs.Items[i].Options then
S := 'ixPrimary, ';
if ixUnique in IndexDefs.Items[i].Options then
S := S + 'ixUnique, ';
if ixDescending in IndexDefs.Items[i].Options then
S := S + 'ixDescending, ';
if ixCaseInsensitive in IndexDefs.Items[i].Options then
S := S + 'ixCaseInsensitive, ';
if ixExpression in IndexDefs.Items[i].Options then
S := S + 'ixExpression, ';
if S > ' ' then begin
{Отфильтровываем ", "}
System.Delete(S, Length(S) - 1, 2);
SG1.Cells[3, i + 1] := S;
end;
end;
end;
end;
end;

Специфичные особенности

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

Таблицы dBASE

При работе с индексами dBASE, свойства Fields и Expression заполняются в зависимости от типа индекса, который может быть как простым (основанным на одном поле), так и сложным (базирующимся на нескольких полях или dBASE-выражениях). Если индекс является простым, свойство Fields будет содержать имя поля таблицы, на основе которого построен индекс, а свойство Expression будет пустым. Если индекс сложный, свойство Expression будет содержать выражение, на основе которого был построен индекс (например, "Field1+Field2"), а свойство Fields будет пустым.

Таблицы Paradox

При работе с первичными индексами Paradox, свойство Name будет пустым, свойство Fields будет содержать поле(я), на основе которых создан индекс, а свойство Options будет содержать ixPrimary. При работе со вторичными индексами, свойство Name будет содержать имя вторичного индекса, свойство Fields будет содержать поле(я), на основе которых создан индекс, а свойство Options может как содержать какое-либо значение, так и быть пустым.

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

Таблицы InterBase

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

Индексы, определенные в команде CREATE TABLE как PRIMARY, в свойстве Name будут содержать значение "RDB$PRIMARYn", где n - порядковый номер символа, однозначно определяющий первичный индекс в пределах метаданных БД. Вторичные индексы содержат фактическое имя индекса.

Внешние ключи также содержат индексы, созданные системой. Такие индексы будут содержаться в свойстве IndexDefs и иметь имя "RDB$FOREIGNn", где n - порядковый номер символа, однозначно определяющий индекс в пределах метаданных БД.

Свойство Fields у индексов, основанных более чем на одном поле, содержит имена полей, разделенных точкой с запятой. Индексы, основанные только на одном поле, в свойстве Fields содержат имя только данного поля. [000942]


Запись/чтение чисел в 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.

- Ralph Friedman [000978]


Поиск величины при вводе I

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Первоначально код писался под 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;
[000029]


Поиск величины при вводе II

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Это просто. Вот что я написал в обработчике события OnChange редактора.

with MainForm.PatientTable do
begin
{ начинаем поиск имени }
IndexName := 'Name';
FindNearest([SearchFor.Text]);
end

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

//bob [000383]


Быстрый поиск в базах данных

Я представляю на Ваш суд утилиту быстрого поиска по базе данных. Данная технология производит поиск по полям, преобразуя их значения в строки (все значения преобразуются в верхний регистр, включая действительные числа). Данное решение может быть не самым быстрым, однако на поверку оно оказывается быстрее остальных, обнаруженных мною в Интернете (может вам повезет больше). Более того, представьте, что действительное значение какого-либо поля равно 4.509375354, а значение поиска равно 7, в этом случае утилита засчитает "попадание". Утилита удобна также тем, что она за один проход производит поиск более, чем в одном поле. Это удобно, если у Вас имеются, к примеру, два поля с адресами. Это моя первая "серьезная" разработка, так как первое, с чем я столкнулся, изучая Delphi, стала необходимость включения процедуры поиска в любое приложение, работающее с базой данных. А так как поиск - вещь тоже сугубо специфическая, как и любое приложение, то мне пришлось побороть свой страх перед "крутым программированием" и попробовать написать свой поисковый механизм, удовлетворивший меня (и, надеюсь, других) своей скоростью и возможностью "мульти"-поиска по нескольким полям. Я надеюсь, что он поможет тем программистам, кто часто сталкивается с подобными задачами. Технология довольно легка для понимания, но если у Вас возникли какие-либо вопросы, пошлите мне письмо электронной почтой, я буду рад Вам помочь. Посмотрев код, можно легко узнать поддерживаемые типы полей (добавить новые не составит проблем). Если кто-либо обнаружит ошибочный код или расширит функциональность утилиты, пожалуйста, пошлите это мне, я буду весьма благодарен. Спасибо.

unit Finder;

interface

uses DB, DBTables, SysUtils;

function GrabMemoFieldAsPChar(TheField : TMemoField): PChar;
function DoFindIn(TheField : TField; SFor : String): Boolean;
function FindIt(TheTable : TDataSet; TheFields : array of integer;
SearchBackward : Boolean; FromBeginning : Boolean; SFor : String): Boolean;
{применение функции FindIt -
if FindIt(NotesSearchT,
[NotesSearchT.FieldByName('Leadman').Index],
False, True, SearchText.Text) then DoSomething; }
implementation

function GrabMemoFieldAsPChar(TheField : TMemoField): PChar;
begin
with TBlobStream.Create(TheField, bmRead) do
begin
GetMem(Result, Size + 1);
FillChar(Result^, Size + 1, #0);
Read(Result^, Size);
Free;
end;
end;

function DoFindIn(TheField : TField; SFor : String): Boolean;
var
PChForMemo : PChar;
begin
Result := False;
case TheField.DataType of
ftString :
begin
if (Pos(SFor, UpperCase(TheField.AsString)) > 0) then
Result := True;
end;
ftInteger :
begin
if (Pos(SFor, TheField.AsString) > 0) then Result := True;
end;
ftBoolean :
begin
if SFor = UpperCase(TheField.AsString) then
Result := True;
end;
ftFloat :
begin
if (Pos(SFor, TheField.AsString) > 0) then Result := True;
end;
ftCurrency :
begin
if (Pos(SFor, TheField.AsString) > 0) then Result := True;
end;
ftDate .. ftDateTime :
begin
if (Pos(SFor, TheField.AsString) > 0) then Result := True;
end;
ftMemo :
begin
SFor[Ord(SFor[0]) + 1] := #0;
PChForMemo := GrabMemoFieldAsPChar(TMemoField(TheField));
StrUpper(PChForMemo);
if not (StrPos( PChForMemo, @SFor[1] ) = nil) then Result :=
True; FreeMem(PChForMemo, StrLen(PChForMemo + 1));
end;
end;
end;

function FindIt(TheTable : TDataSet; TheFields : array of integer;
SearchBackward : Boolean; FromBeginning : Boolean; SFor : String): Boolean;
var
i, HighTheFields, LowTheFields : integer;
BM : TBookmark;
begin
TheTable.DisableControls;
BM := TheTable.GetBookmark;
try
LowTheFields := Low(TheFields);
HighTheFields := High(TheFields);
SFor := UpperCase(SFor);
Result := False;
if FromBeginning then TheTable.First;
if SearchBackward then
begin
TheTable.Prior;
while not TheTable.BOF do
begin
for i := LowTheFields to HighTheFields do
begin
if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
begin
Result := True;
Break;
end;
end;
if Result then Break else TheTable.Prior;
end;
end else
begin
TheTable.Next;
while not TheTable.EOF do
begin
for i := LowTheFields to HighTheFields do
begin
if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
begin
Result := True;
Break;
end;
end;
if Result then Break else TheTable.Next;
end;
end;
finally
TheTable.EnableControls;
if not Result then
TheTable.GotoBookmark(BM);
TheTable.FreeBookmark(BM);
end;

end;

end.
[000030]


Поиск записи в больших таблицах

Вот один из советов читателей. Привожу письмо полностью.

Доброго времени суток, Валентин.

Прочитал Ваши "Советы по Delphi" - спасибо большое: понравилось и, главное, помогло - никак не получалось нарисовать круглую форму. В свою очередь хочу предложить на Ваш суд небольшую процедуру, которая мне очень помогла. Процедура позволяет переходить на любую из записей в таблице (формат Paradox или DBase). Необходимость в ней возникла, когда мне пришлось работать с таблицей размером в 10 и более тысяч записей у которой было несколько калькулируемых полей и полей подлинкованных из объектов TQuery. При использовании метода TTable.MoveBy программа медленно и печально замолкала (вообще-то она работала, но как?!). Встретил я этот пример в технической документации Borland (2656), где сравнивались функции Paradox Engine и BDE. Пример был написан на C. Вот его интерпретация на Delphi:

uses
... BDE, DBTables;

function MoveToRec(RecNo: longint;taSingle: TDBDataSet): DBIResult;
var
CursorProps: CurProps;
begin
Result:= DbiGetCursorProps(taSingle.Handle, CursorProps);

if Result = DBIERR_NONE then begin
case TTable(taSingle).TableType of
ttParadox: Result:= DbiSetToSeqNo(taSingle.Handle,RecNo);
ttDBase: Result:= DbiSetToRecordNo(taSingle.Handle,RecNo);
else
Result:= DBIERR_NOTSUPPORTED;
end;{ case..}

//------------------------------------
if Result = DBIERR_NONE then
taSingle.Resync([rmCenter]);
//------------------------------------
end{ if..}
end;

С уважением, Александр Куприн. [000226]


Хитрость OnCalcFields

Событие OncalcFields генерится ОЧЕНЬ часто и может быть необязательным и занимать большое количество времени, например, у вас есть таблица с неким вычисляемым полем, и при каждом редактировании таблицы вызывается следующий код:

MyCalcField.AsInteger := Table1Field1.AsInteger + 10;

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

Мой совет следующий: выключите генерацию события OnCalcFields, обработайте все поля и снова включите генерацию данного события, к примеру так:

Procedure TForm1.BigProcessingFunction;
begin
Table1.OnCalcFields := nil;

<Включите любые по сложности вычисления в этом месте!>

Table1.OnCalcFields := Table1OnCalcFields;

end;

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

Данный метод позволяет исключить необязательный код и может быть использован повсюду, где применяются большие таблицы или сложный алгоритм калькуляции поля. Разница в скорости обработки таблицы довольно ощутима. [000031]


Delphi 1

Вычисление суммы полей

Создайте TQuery с SQL запросом подобно этому:

Select Sum(Field) From "Table.dbf"

Дважды щелкните на TQuery и в открывшемся редакторе полей выберите "Add" (добавить). В нашем случае это будет SumOfField. Затем в обработчике события OnCalcFields сошлитесь на Query1SumOfField (например, Table1TotalSalary.Value := Query1SumOfField.AsInteger ;). [000451]


Одной строкой

Функция вычисления суммы полей

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;

Спасибо Alexsander за ценное замечание [000542]


Таблицы dBASE: Структура .DBF-файла

Иногда возникает необходимость поработать с таблицей dBASE напрямую, без Borland Database Engine (BDE). К примеру, если .DBT-файл (содержащий MEMO-данные) для данной таблицы безвозвратно потерян, .DBF-файл становится абсолютно непригодным, поскольку байт в заголовке .DBF-файла указывает, что таблица должна содержать соответствующий MEMO-файл. Решение этой проблемы потребует обнуление этого байта, для того чтобы таблица не указывала на сопутствующий MEMO-файл. Или, если Вам захотелось написать собственную программу для работы с данными.

Ниже приводяся структуры .DBF-файлов для таблиц dBASE. Представлены структуры файлов для различных версий dBASE: dBASE III PLUS 1.1, dBASE IV 2.0, dBASE 5.0 под DOS и dBASE 5.0 для Windows.

Структура заголовка файла данных для таблицы dBASE III PLUS.

Заголовок табличного файла
Байт | Содержание | Описание
0 | 1-й байт | Определение наличия MEMO-файла в таблице dBASE III PLUS (03h без MEMO-файла (.DBT-файл;) 83h с MEMO-файлом).
1-3 | 3 байта | Дата последнего обновления в формате YYMMDD
4-7 | 32-битное число | Количество записей в таблице
8-9 | 16-битное число | Количество байтов, занимаемых заголовком
10-11 | 16-битное число | Количество байтов, занимаемых записью
12-14 | 3 байта | Зарезервированная область
15-27 | 13 байт | Зарезервировано для сетевой версии dBASE III PLUS
28-31 | 4 байта | Зарезервированная область
32-n | 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже)
n+1 | 1 байт | Хранится значение 0Dh, выполняющее роль терминатора описаний полей

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы
Байт | Содержание | Описание
0-10 | 11 байт | Имя поля в ASCII (заполнено нулями).
11 | 1 байт | Тип поля в ASCII (C, D, L, M или N)
12-15 | 4 байта | Адрес данных поля (ссылка на память, а не на диск)
16 | 1 байт | Размер поля в бинарном формате
17 | 1 байт | Порядковый номер поля в бинарном формате
18-19 | 2 байта | Зарезервировано для сетевой версии dBASE III PLUS
20 | 1 байт | ID рабочей области
21-22 | 2 байта | Зарезервировано для сетевой версии dBASE III PLUS
23 | 1 байт | Флаг установки поля
24-31 | 1 байт | Зарезервированная область

Записи таблицы

Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.

Допустимый тип данных таблиц dBASE
Тип данных | Возможные значения
C (Символы) | Все символы кодовой страницы OEM
D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD)
N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9
L (Логический) | ? Y y N n T t F f (? - не инициализировано)
M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока)

Бинарные-, MEMO-, OLE-поля и .DBT-файлы

MEMO-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Размер блока равен 512 байт. Первый блок в .DBT-файле (нулевой блок) - заголовок .DBT-файла.

MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

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

Данная информация взята из руководства по использованию dBASE III Plus ("Using dBASE III PLUS", Appendix C).

Структура заголовка файла данных для таблицы dBASE IV 2.0.

Структура файла
Байт | Содержание | Описание
0 | 1-й байт | Контроль файла dBASE IV: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV, биты 4-6 - наличие SQL-таблицы, бит 7 - наличие любого MEMO-файла (или dBASE III Plus, или dBASE IV)
1-3 | 3 байта | Дата последнего обновления в формате YYMMDD
4-7 | 32-битное число | Количество записей в таблице
8-9 | 16-битное число | Количество байтов, занимаемых заголовком
10-11 | 16-битное число | Количество байтов, занимаемых записью
12-13 | 2 байта | Зарезервированная область, заполнена нулями
14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции
15 | 1 байт | Флаг кодировки
16-27 | 12 байт | Зарезервированная область для многопользовательского использования dBASE IV
28 | 1 байт | Флаг наличия MDX-файла: 01H - файл присутствует, 00H - файл отсутствует
29 | 1 байт | ID драйвера языка
30-31 | 2 байта | Зарезервированная область, заполнена нулями
32-n* | по 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже)
n+1 | 1 байт | 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы
Байт | Содержание | Описание
0-10 | 11 байт | Имя поля в ASCII (заполнено нулями).
11 | 1 байт | Тип поля в ASCII (C, D, F, L, M или N)
12-15 | 4 байта | Зарезервированная область
16 | 1 байт | Размер поля в бинарном формате
17 | 1 байт | Порядковый номер поля в бинарном формате
18-19 | 2 байта | Зарезервированная область
20 | 1 байт | ID рабочей области
21-30 | 10 байт | Зарезервированная область
31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет.

Записи таблицы:

Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah).

Допустимый тип данных таблиц dBASE
Обозначение типа | Тип | Диапазон значений
C | Символы | Все символы кодовой страницы OEM
D | Дата | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD)
F | Бинарные числа с плавающей точкой | - . 0 1 2 3 4 5 6 7 8 9
N | Десятичное преобразование бинарных чисел | - . 0 1 2 3 4 5 6 7 8 9
L | Логический | ? Y y N n T t F f (? - не инициализировано)
M | Мемо | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока)

Memo-поля и .DBT-файлы

MEMO-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Переменная BLOCKSIZE определяет размер каждого блока. Первый блок в .DBT-файле (нулевой блок) - заголовок .DBT-файла.

MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

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

Данная информация взята из справочника по dBASE IV ("dBASE IV Language Reference", Appendix D).

Структура заголовка файла данных для таблицы dBASE 5.0 под DOS.

Заголовок табличного файла
Байт | Содержание | Описание
0 | 1-й байт | Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows)
1-3 | 3 байта | Дата последнего обновления в формате YYMMDD
4-7 | 32-битное число | Количество записей в таблице
8-9 | 16-битное число | Количество байтов, занимаемых заголовком
10-11 | 16-битное число | Количество байтов, занимаемых записью
12-13 | 2 байта | Зарезервированная область, заполнена нулями
14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции
15 | 1 байт | Флаг кодировки
16-27 | 12 байт | Зарезервированная область для многопользовательского использования
28 | 1 байт | Флаг наличия MDX-файла: 01H - файл присутствует, 00H - файл отсутствует
29 | 1 байт | ID драйвера языка
30-31 | 2 байта | Зарезервированная область, заполнена нулями
32-n* | по 32 байта | Массив с описаниями полей (структура каждого такого описания показана ниже)
n+1 | 1 байт | 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы
Байт | Содержание | Описание
0-10 | 11 байт | Имя поля в ASCII (заполнено нулями).
11 | 1 байт | Тип поля в ASCII (B, C, D, F, G, L, M или N)
12-15 | 4 байта | Зарезервированная область
16 | 1 байт | Размер поля в бинарном формате
17 | 1 байт | Порядковый номер поля в бинарном формате
18-19 | 2 байта | Зарезервированная область
20 | 1 байт | ID рабочей области
21-30 | 10 байт | Зарезервированная область
31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет.

Записи таблицы

Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.

Допустимый тип данных таблиц dBASE
Тип данных | Возможные значения
C (Символы) | Все символы кодовой страницы OEM
D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD)
F (Бинарные числа с плавающей точкой) | - . 0 1 2 3 4 5 6 7 8 9
N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9
L (Логический) | ? Y y N n T t F f (? - не инициализировано)
M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока)

MEMO-поля и .DBT-файлы

MEMO-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Переменная BLOCKSIZE определяет размер каждого блока. Первый блок в .DBT-файле (нулевой блок) - заголовок .DBT-файла.

MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

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

Если вы удаляете текст в МЕМO-поле, в отличие от dBASE III PLUS, таблица dBASE 5.0 под DOS для ввода нового текста использует удаленную область. dBASE III PLUS всегда добавляет новый текст в конец .DBT-файла. В dBASE III PLUS размер .DBT-файла растет всякий раз при добавления нового текста, даже если перед этим текст был удален.

Данная информация взята из справочника по dBASE под DOS ("dBASE for DOS Language Reference manual", Appendix C).

Структура заголовка файла данных для таблицы dBASE 5.0 под Windows.

Заголовок табличного файла
Байт | Содержание | Описание
0 | 1-й байт | Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows)
1-3 | 3 байта | Дата последнего обновления в формате YYMMDD
4-7 | 32-битное число | Количество записей в таблице
8-9 | 16-битное число | Количество байтов, занимаемых заголовком
10-11 | 16-битное число | Количество байтов, занимаемых записью
12-13 | 2 байта | Зарезервированная область, заполнена нулями
14 | 1 байт | Флаг, указывающий на наличие незавершенной транзакции dBASE IV
15 | 1 байт | Флаг кодировки таблицы dBASE IV
16-27 | 12 байт | Зарезервированная область для многопользовательского использования
28 | 1 байт | Флаг наличия MDX-файла: 01H - файл для данной таблицы присутствует, 00H - файл отсутствует
29 | 1 байт | ID драйвера языка
30-31 | 2 байта | Зарезервированная область, заполнена нулями
32-n | по 32 байта | Массив с описаниями полей (структура данного массива показана ниже)
n+1 | 1 байт | 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы
Байт | Содержание | Описание
0-10 | 11 байт | Имя поля в ASCII (заполнено нулями).
11 | 1 байт | Тип поля в ASCII (B, C, D, F, G, L, M или N)
12-15 | 4 байта | Зарезервированная область
16 | 1 байт | Размер поля в бинарном формате
17 | 1 байт | Порядковый номер поля в бинарном формате
18-19 | 2 байта | Зарезервированная область
20 | 1 байт | ID рабочей области
21-30 | 10 байт | Зарезервированная область
31 | 1 байт | Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H - нет.

Записи таблицы

Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) - запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.

Допустимый тип данных таблиц dBASE
Тип данных | Возможные значения
B (Бинарный) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока).
C (Символы) | Все символы кодовой страницы OEM
D (Дата) | Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD)
G (Общий) | Все символы кодовой страницы OEM или OLE (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока).
N (Числовой) | - . 0 1 2 3 4 5 6 7 8 9
L (Логический) | ? Y y N n T t F f (? - не инициализировано)
M (Мемо) | Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока)

Бинарные, МЕМО, OLE-поля и .DBT-файлы

Бинарные, MEMO и OLE-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Переменная BLOCKSIZE определяет размер каждого блока. Первый блок в .DBT-файле (нулевой блок) - заголовок .DBT-файла.

Бинарное, OLE- или MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

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

Если вы удаляете текст в бинарном, OLE- или МЕМO-поле, в отличие от dBASE III PLUS и dBASE IV, таблица dBASE 5.0 под Windows для ввода нового текста использует удаленную область. dBASE III PLUS всегда добавляет новый текст в конец .DBT-файла. В dBASE III PLUS размер .DBT-файла растет всякий раз при добавления нового текста, даже если перед этим текст был удален.

Данная информация взята из справочника по dBASE под Windows ("dBASE for Windows Language Reference manual", Appendix C).

Предупреждение: У Вас есть право использовать данную техническую информацию с продуктом фирмы Borland только лишь в случае, когда это не противоречит Лицензионному соглашению, поставляемую с программным продуктом.
[000063]


Delphi 1

Пакование таблиц dBASE

Для упаковки таблицы dBASE убедитель в том, что таблица открыта в монопольном (exclusive) режиме и вызывайте DbiPackTable. Пример:

Table1.Close ;
Table1.Exclusive := TRUE ;
Table1.Open ;
DbiPackTable( Table1.DBHandle, Table1.Handle, nil, nil, TRUE ) ;

Убедитесь, что DBITYPES, DBIPROCS, DBIERRS включены в секцию USES вашего модуля и, в случае запуска из-под IDE, в режиме проектирования таблица не активна.

OAmiry/Borland [000372]


Delphi 1

Обработка исключения `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.

[000531]


Delphi 1

DBase и 'особые случаи' BDE

Dbase является причиной бОльшего количества 'special case' в BDE, чем таблицы SQL и Paradox из-за поддержки "Выражений в Индексах" (Expressions in indexes) и т.д., и т.п..

  1. Создание/пересоздание индекса
    • DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }
    • create index (зависит от существования выражения)

      if (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then
      Table1.AddIndex( cTagName, cTagExp, [ixExpression])  (<- ixExpression - _литерал_)
      else
      Table1.AddIndex( cTagName, cTagExp, []);

  2. Мастер/Деталь связан с выражением дочернего индекса
    • вызов BDE процедуры DbiLinkDetailToExp() вместо обычной DbiLinkDetail()
  3. Упаковка таблиц
    with Table1 do
    StrPCopy( TName, TableName );
    Result := DBIPackTable( DbHandle, Handle, TName, szDBASE, TRUE );

  4. Установка видимости удаленных записей, on/off (т.е. dBase SET DELETED ON/OFF)
    DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue));

  5. Установка символа частичного/точного соответствия, on/off (т.е. dBase SET EXACT ON/OFF)
    DbiSetProp( hDBIObj(Table1.Handle), curINEXACTON, LongInt(bValue));

[000561]


Delphi 1

DBFSeek и DBFLocate

Надежней и намного быстрее (если вы ищите отдельные записи) выполнить поиск строки с помощью Seek (если найдена первая запись), или выполнить Locate (индекс не требуется)

например

Table1.UpdateCursorPos;
if DBFSeek( Table1, xVal1 ) then           {_не_ delphi-функция - смотри ниже}
begin
if DBFLocate( Table1, 'CUSTNAME', xVal2  ) then   {_не_ delphi-функция - модификация из faq)
begin
... делаем все, что необходимо
end;
end;

Tom

ps.

  1. DBFLocate - модифицированная из faq фунция fieldname
  2. 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;

[000563]


Delphi 1

dBASE - Индексы выражений

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 третьих фирм.

    [000630]


Delphi 1

Текущий RecNo (dBase/Pdox)

...какой метод вовращает номер текущей записи? (т.е.: Я хочу использовать это вместе с функцией RecordCount и выводить для пользователя в строке состояния нечто вроде: "Запись #n из x")

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

function RecordNumber(Dataset: TDataset): Longint;
var
CursorProps: CurProps;
RecordProps: RECProps;

begin
{ Возвращаем 0, если набор данных не Paradox или dBASE }
Result := 0;

with Dataset do begin
{ Набор данных активен? }
if State = dsInactive then
DBError(SDataSetClosed);

{ Нам необходимо сделать этот вызов, чтобы "захватить" курсор iSeqNums }
Check(DbiGetCursorProps(Handle, CursorProps));

{ Синхронизируем курсор BDE с курсором набора данных }
UpdateCursorPos;

{ Заполняем RecordProps текущими свойствами записи }
Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));

{ С каким типом набора данных мы работаем? }
case CursorProps.iSeqNums of
0: Result := RecordProps.iPhyRecNum;  { dBASE   }
1: Result := RecordProps.iSeqNum;     { Paradox }
end; { case }
end; { with }
end; { function }

Затем, в обработчике события OnDataChange DataSet, я использовал команду:

MyTextVariable := 'Запись ' + IntToStr( RecordNumber( tImport ) ) +
' из ' + IntToStr( tImport.RecordCount ) ;

Mike Downey [000738]


Восстановление записи dBase

После удаления записи из таблицы (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 [000815]


Формат и размер dBase-поля

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

Следующий код иллюстрирует необходимые вызовы BDE:

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 [000830]


Delphi 1

Форматированные Memo-поля таблиц Paradox

Форматированные Memo-поля - классная штука, с тех пор, как Paradox стал единственным форматом, который знает, как их отображать.

Если в ближайшее время вы планируете использовать таблицы в Delphi, то вероятно лучшем решением на данный момент является преобразование ascii blob-полей в Memo-поля Paradox. [000340]


Delphi 1

Создание autoincrement поля

Согласно электронной документации по DBD, "автоприращиваемое" (Autoincrement) поле таблиц Paradox должно содержать значение Valcheck Minimum value.

Это отлично работает с новой таблицей, но вы не сможете добавить Аutoincrement поле к существующей таблице, т.к. все значения Valchecks неактивны!

Решение: измените тип поля с + на N, установите минимальное значение и восстановите тип поля на +. [000349]


Delphi 1

Вызов TUTILITY

BTW, у кого-нибудь есть пример вызова 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.
[000379]


Delphi 1

Пароли Paradox

Как мне при соединении с таблицей Paradox устранить/"удовлетворить" окошко с требованием ввести пароль, защищающей таблицу?

Свойство компонента Table ACTIVE должно быть установлено в FALSE. (Если она активна прежде, чем вы ввели пароль, вы получите это окошко.) Затем поместите следующий код в обработчике события формы OnCreate:

session.AddPassword('Мой секретный пароль');
table1.active := true;

[000440]


Delphi 1

Печать структуры таблицы Paradox

Вот код печати структуры таблицы Paradox, состряпанный на скорую руку. Предполагается, что компонент Table имеет имя Table1.

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;

[000455]


Delphi 1

Каскадированное удаление с проверкой целостности 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), с которым производится сопоставление.

[000631]


Delphi 1

Ограничения Paradox

Какой предел IDAPI для подключенных пользователей и размера файла для таблиц Paradox?

255 пользователей, максимальный размер таблицы по умолчанию от 128Мб до 4Гб, в зависимости от установки BLOCKSIZE в IDAPI.CFG во время создания таблицы. (максимальный размер = BLOCKSIZE x 64Mb).

Eryk [000706]


Delphi 1

Медленное открытие таблицы Paradox?

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

Rich Jones [000712]


Delphi 1

Чтение OLE из Blob поля Paradox

...после моих дискуссий с людьми из службы технической поддержки 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... если это так, то это легко обойти.

Eryk [000733]


Delphi 1

Пакование таблиц Paradox и dBASE

Возвожно ли перестраивать и паковать таблицы Paradox из программ, написанных на Delphi, если да то как и где найти документацию по этому вопросу?

Попробуйте приведенную ниже функцию, она пакует таблицы Paradox и dBase (требуется компонент TDatabase, указывающий на ту же директорию, где хранятся таблицы):

uses  DBIProcs, DBITypes, DBIErrs;

function PackTable(tbl:TTable; db:TDatabase):DBIResult;
var
crtd: CRTblDesc;
begin
Result := DBIERR_NA;
with tbl do if Active then Active := False;
with db do if not Connected then Connected := True;
FillChar(crtd,SizeOf(CRTblDesc),0);
StrPCopy(crtd.szTblName,tbl.TableName);
crtd.bPack := True;
Result := DbiDoRestructure(db.Handle,1,@crtd,nil,nil,nil,FALSE);
end;

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

procedure TForm1.Button1Click(Sender: TObject);
begin
if PackTable(Table1,DataBase1) = DBIERR_NONE then .....
else MessageBeep(0);
end;

=== Mike Orriss === [000739]


Delphi 1

Дубликат Paradox/dBase записи

Существует ли какое-либо простое решение для Delphi-приложения, позволяющее прочесть запись из первого поля таблицы Paradox (первичный ключ) и потом обратно добавить ее в таблицу в виде новой записи?

Вот одно "кривое" решение:

procedure TForm1.Button1Click(Sender: TObject);
var
p : CURProps;
begin
Table2.Insert;
DbiGetCursorProps(Table1.Handle,p);
Move(Table1.ActiveBuffer^,Table2.ActiveBuffer^,p.iRecBufSize);
Table2.FieldByName('ID').AsInteger := Table1.FieldByName('ID').AsInteger + 1;
Table2.Post;
end;

...это работает на том "основании", что как Table1, так и Table2 ссылаются на один и тот же табличный файл. Вы могли бы осуществить это и с единственным TTable, если сохраните содержание в активном буфере (ActiveBuffer).

- Eryk Bottomley [000767]


Delphi 1

Изменение месторасположения *.NET-файла во время работы

Кто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?

DbiSetProp(hSessionHandle, sesNetFile, pchar('c:\newdir'));

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

- Scott Frolich [000771]


Delphi 1

Paradox в сети

Может мне кто-нибудь помочь? Я получаю следующую ошибку приложения....Not initialized for accessing network files (не инициализировано для доступа к сетевым файлам).

Программа Borland BDE Install НЕ включает в себя автоматически драйвер для работы в сети для таблиц Paradox, если целевой компьютер подключен к сети. Ваш пользователь получит сообщение об ошибке, если путь никем не установлен. Программы третьих фирм, устанавливающие BDE, поступают точно так же (я использую WISE). Настройка сетевого каталога возможна программным путем из самой программы, или с помощью пользователя и утилиты BDEconfig.

При запуске приложения я разворачиваю предусмотренную Borland DLL "netdir.dll" (58K), загруженную из форума PdoxWin, получаю доступ к idapi.cfg и считываю значение сетевого каталога (netdir). Следующий код проверяет был ли установлен сетевой каталог, и, если не был, то он временно устанавливается для текущего сеанса пользователя.

{объявляем DLL функцию}
function getCFGNetDir :pchar; far; external 'netdir' index 4;

{проверяем и при необходимости восстанавливаем сетевой каталог}
procedure TmySplashForm.FormCreate(Sender: TObject);
var
theNetDir : pchar ;
theChar : char;

begin
theChar := ':'
theNetDir := getCFGNetDir;
if (strscan(theNetDir,theChar) = nil) then
session.netfiledir := 'C:\' ;
end;

- James Presley [000798]


Слухи

Вскрытие запароленной таблицы Paradox

Александр Демский сплетничает:

Предупрежден - значит, вооружен. Берем Парадоксовскую табличку, паролим ее самым секретным паролем, бумажку с паролем сжигаем, а сам пароль забываем. Что теперь делать? Да ничего, просто открываем нашу табличку с одним из паролей: jIGGAe, nx66ppx, cupcdvum. Один, да подойдет. Не доверяйте своих секретов буржуям! [000905]


Размеры полей таблицы 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 [000931]


Paradox и неверные индексы Win95

Сообщение об ошибке: В файловой системе 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)
(Выключить общий доступ к новым файлам и семантику блокировки)
- David W. Husch [000980]


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

Может кто-нибудь, предпочтительно из персонала 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 и данные вашей таблицы появятся в табличной сетке.
[000376]


Delphi 1

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

Можно ли как-то в Delphi работать с файлами Microsoft Access? Я слышал что некоторые программисты пробовали, но у них ничего не получилось.

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

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

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

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

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

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


Работа с индексами 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.

[000975]


Сканирование версии структуры базы данных

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

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

(*****************************************************************************
* DbUtils.pas
*
* Утилита для работы с базами данных
*
* Создана 09/20/96
*****************************************************************************) unit Dbutils;

(****************************************************************************)
(****************************************************************************)
interface
(****************************************************************************)
(****************************************************************************)

uses
DbTables;

function DbGetVersion(table: TTable): LongInt;

(****************************************************************************)
(****************************************************************************)
implementation
(****************************************************************************)
(****************************************************************************)

uses
Db, DbiProcs, DbiTypes, {DbiErrs,}
SysUtils;

{---------------------------------------------------------------------------}
(*
* Цель:                    определение номера версии структуры таблицы
* Параметры:               table (I) - интересующая нас таблица
* Возвращаемая величина:   номер версии
* Исключительная ситуация: EDatabaseError
*)
function DbGetVersion(table: TTable): LongInt;
var
hCursor   : hDBICur;
tableDesc: TBLFullDesc;
cName     : array[0..255] of Char;
begin
{ копируем имя таблицы в строку 'с' }
StrPCopy(cName, table.TableName);

{ просим BDE создать запись, содержащую информацию об определенной таблице }
Check(DbiOpenTableList(table.DBHandle, True, False, cName, hCursor));

{ получаем запись, содержащую информацию о структуре }
Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @tableDesc, nil));

{ возвращаем поле записи, содержащее номер версии структуры нашей таблицы }
Result := tableDesc.tblExt.iRestrVersion;

Check(DbiCloseCursor(hCursor));
end;

end.
[000032]


Перемещение таблиц

Здесь я привожу примеры программ, которые я использую для копирования и удаления таблиц. Необходимые для работы модули: DB, DBTables, DbiProcs,DbiErrs, и DbiTypes. Вам всего лишь необходимо указать каталог расположения, исходное имя таблицы, каталог назначения и имя таблицы, куда будет скопирована исходная таблица и BDE скопирует таблицу целиком со всеми индексами. Процедура удаления в качестве входных параметров использует каталог расположения и имя таблицы, при этом BDE удаляет как саму таблицу, так и все файлы, связанные с ней (индексы и т.п.). Для тестирования данные процедуры были помещены в новое приложение и мне пришлось их немного отредактировать, чтобы удалить некоторые зависимости, которые были связаны с главной формой приложения. Теперь процедуры являются полностью автономными и могут быть помещены в отдельный модуль. (Не забудьте включить его в список используемых модулей). Пользуйтесь на здоровье!

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('При копировании ' +
FromDir + '\' + SrcTblName + ' в ' +
ToDir + '\' + DestTblName + ' ,'
+ 'BDE сгенерировал ошибку '''
+ 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;
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('Удаляя ' +
Dir +   '\' + TblName + ', BDE ' +
'сгенерировал ошибку '''
+ StrPas(Err) + '''');
end;
finally
SrcTbl.Free;
end;
end;
[000033]


Прокрутка таблицы: хитрость 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() могут применяться где-нибудь еще. [000034]


Запись nnn из nnn

Нет ли метода или свойства, позволяющих осуществить сабж из Delphi?

Для этого необходимо поработать с BDE. Нижеприведенный код у меня работает прекрасно. Условия выполнения:
A) Вы используете таблицы dBASE
B) На форме расположен компонент DBNavigator
B) На форме расположен табличный компонент с именем Table1
C) На форме расположен компонент Label с именем Label1
D) Обработчик события OnClick компонента DBNavigator имеет следующий код:

procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var
pRecProperty: pRECProps ;
begin
if Button in [nbFirst, nbPrior, nbNext, nbLast] then
begin
if MaxAvail > SizeOf(RECProps) then
begin
GetMem( pRecProperty, SizeOf(RECProps) ) ;
DbiGetRecord( Table1.Handle, dbiNOLOCK, nil, pRecProperty ) ;
Label1.Caption := Concat( 'Запись: ', IntToStr(pRecProperty^.iPhyRecNum),
' из ', IntToStr(Table1.RecordCount) ) ;
FreeMem( pRecProperty, SizeOf(RECProps) ) ;
end ;
end ;
end;

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

OAmiry/Borland [000382]


Delphi 1

Копирование массива целочисленных чисел в Blob-поле

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

Запишите массив в поток памяти и затем используйте метод TBlob LoadFromStream. Для извлечения данных используйте метод TBlob SaveToStream (сохранение и извлечение массива из потока памяти). [000402]


Одной строкой

Копирование StringList в Memo-поле и обратно

Нижеприведенный код иллюстрирует копирование TStringList в TMemoField и обратно:

procedure TForm1.ButtonClick(Sender: TObject);
var
MemFld: TMemoField;
begin
MemFld := Table1.FieldByName(DBMemo1.DataField) as TMemoField;
if Sender = Button1 then MemFld.Assign(StrList)
else if Sender = Button2 then StrLst.Assign(MemFld);
end;

Примечание: Table1 должна находиться в режиме редактирования перед нажатием кнопки Button1. [000465]


Delphi 1

Копирование записи из одной таблицы в другую

procedure TTableRecordCopy(Source, Destination: TTable);
{ПРЕДПОЛОЖЕНИЕ: Обе таблицы имеют курсор в нужной строке и
компоненты Table ссылаются на таблицы с совместимыми величинами.}
var
i, lCount: Integer;
begin
lCount := Source.FieldCount;
for i := 0 to lCount - 1 do
if (not Source.Fields[i].IsNull) and (Source.Fields[i].CanModify) then
Destination.FieldByName(Source.Fields[i].FieldName).Assign(Source.Fields[i]);
end;

Это работает для всех типов полей.

Josh [000487]


Delphi 1

Полный слепок полей таблицы

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

Приведенный ниже пример демонстрирует технологию полного воспроизведения доступных полей в компоненте TTable или TQuery. Программа извлекает информацию о доступных полях и отображает ее в компоненте TListBox; эта информация необходима для динамического построения потомков TField. В данном примере источником данных служит компонент TTable, но той же цели может служить и TQuery (TTable и TQuery для доступа к полям таблицы используют одно и то же свойство Fields).

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
F: TFieldDef;
D: String;
begin
Table1.Active := True;
ListBox1.Items.Clear;

with Table1 do begin
for i := 0 to FieldDefs.Count - 1 do begin
F := FieldDefs.Items[i];
case F.DataType of
ftUnknown: D := 'Unknown';
ftString: D := 'String';
ftSmallint: D := 'SmallInt';
ftInteger: D := 'Integer';
ftWord: D := 'Word';
ftBoolean: D := 'Boolean';
ftFloat: D := 'Float';
ftCurrency: D := 'Currency';
ftBCD: D := 'BCD';
ftDate: D := 'Date';
ftTime: D := 'Time';
ftDateTime: D := 'DateTime';
ftBytes: D := 'Bytes';
ftVarBytes: D := '';
ftBlob: D := 'BLOB';
ftMemo: D := 'Memo';
ftGraphic: D := 'Graphic';
else
D := '';
end;
ListBox1.Items.Add(F.Name + ', ' + D);
end;
end;
Table1.Active := False;
end;

[000533]


Delphi 1

Правила для 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

Я не знаю, поняли вы это или нет, но надеюсь это поможет...

Josh [000564]


Delphi 1

ActiveControl имеет DataSet?

Для успешного кодирования необходимо включить typinfo в список используемых модулей. Код данного примера инвертирует логическое свойство Active набора данных, связанного с активным элементом управления при каждом нажатии пользователем клавиши ESC.

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
PropInfo: PPropInfo ;
PropValue: TObject;
ds: TDataSource ;
begin
if Key = VK_ESCAPE then
{ Основной код ниже }
try
ds := nil ;
{ Проверяем, имеет ли компонент свойство DataSource }
PropInfo := GetPropInfo(ActiveControl.ClassInfo, 'DataSource') ;
if PropInfo <> nil then
{ Свойство компонента datasource типа class (например, TDataSource) }
if PropInfo^.PropType^.Kind = tkClass then
begin
PropValue := TObject(GetOrdProp(ActiveControl, PropInfo));
{ Создаем слепок найденного TDataSource }
ds := (PropValue as DB.TDataSource);
{ Используем dataset, связанный с datasource }
if not (ds.DataSet.State in dsEditModes) then
ds.DataSet.Active := not ds.DataSet.Active ;
end ;
except
on E: EInvalidCast do ShowMessage('Ошибка. Ожидался DataSource') ;
end ;
end;

OAmiry/Borland [000566]


Delphi 1

Копирование записи в пределах одной и той же таблицы

"Каким образом мне копировать запись в пределах одного и того же TTable? То есть, если я вижу текущую запись на экране и хочу ее скопировать в ту же таблицу с изменением индекса поля(ей), то какие действия мне необходимо предпринять?"

Необходимы два TTable, связанные с одной таблицей. Когда Table1 позиционируется в копируемой строке, с помощью Table2 вы можете выполнить операцию добавления записи. Пример: {только для демонстрации идеи, пример может быть нерабочим}

procedure TForm1.Button1Click(Sender: TObject);
var
i: Cardinal ;
srcStream: TBlobStream ;
begin
try
with Table1 do
begin
CheckBrowseMode ;
if EOF or BOF then raise Exception.Create('Разместите курсор на правильной строке');
end ;
with Table2 do
begin
Append ;
for i := 0 to Table1.FieldCount - 1 do
if Table1.Fields[i].DataType < ftBytes then
FieldByName(Table1.Fields[i].FieldName).Assign(Table1.Fields[i])
else
try
srcStream := nil ;
srcStream := TBlobStream.Create(TBlobField(Table1.Fields[i]), bmRead) ;
TBlobField(FieldByName(Table1.Fields[i].FieldName)).LoadFromStream(srcStream) ;
finally
if Assigned(srcStream) then srcStream.Free ;
end ;
Post ;
end ;
except
on E: EDBEngineError do MessageDlg(E.Message, mtError, [mbOk], 0) ;
on E: Exception do MessageDlg(E.Message, mtError, [mbOk], 0) ;
end ;
end;

OAmiry/Borland [000599]


Delphi 1

Определение типа базы данных

"Могу ли я при помощи объекта Tdatabase узнать с каким типом базы данных он связан?"

{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 [000600]


Delphi 1

Простой пример работы с базой данных из DLL

Это простейший DLL, экспортирующий единственную функцию. Вызывающий ее оператор передает функции значение ключа и строку со значением. Функция открывает демонстрационную базу данных BIOLIFE, находит по ключу запись и добавляет строку после всех записей в поле Notes:

library Mydll;

uses
DBTables;

function Modify(Key: Double; const Info: String): Boolean; export;
var
Table: TTable;
Stream: TBlobStream;
begin
Table := TTable.Create(nil);
Table.DatabaseName := 'D:\';
Table.TableName := 'BIOLIFE';
Table.TableType := ttParadox;
Table.Open;
if Table.FindKey([Key]) then
begin
Result := True;
Table.Edit;
Stream := TBlobStream.Create(TMemoField(Table.FieldByName('Notes')),
bmReadWrite);
Stream.Seek(0, 2);
Stream.Write(Info[1], Length(Info));
Stream.Free;
Table.Post;
end
else Result := False;
Table.Free;
end;

exports
Modify;

begin
end.

Вот как это можно вызвать из приложения:

function Modify(Key: Double; const Info: String): Boolean; far;
external 'MYDLL';

...

Modify(90200, 'Васек Трубачев');

и это классно работает.

Поскольку в DLL вы используете BDE, изучите текущие замечания относительно его использования в файле README.TXT.

- Steve Schafer [000789]


Стандартный запрос на удаление записи в таблице

Галимарзанов Фанис советует:

procedure DelRec(inSet:TDataSet);
begin
if (NotEmptySet(inSet)) and // если таблица пуста - незачем выводить запрос
(Application.MessageBox('Удалить запись?','Внимание!!!',
mb_YesNo+mb_Iconquestion)=idYes) then
inSet.Delete;
end;

[000793]


Сортировка связанного списка

Вот пример:

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.

- Peter Below [000809]


Работа с автоинкрементальными (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).

[000844]


Фильтр посредством логического поля

В таблице имеется поле Customer:Boolean. Я хочу чтобы таблица показывала только Customer или только не-customer.

Установите ключ (вы должны иметь индекс для этого поля) одним из указанных способов:

tablex.SetRange([False],[False])  для всех не-customer...
tablex.SetRange([True],[True]])   для всех customer...
tablex.SetRange([False],[True])   для всех записей...

- Matthew Augier [000873]


Delphi 1

Причуда AddIndex

При попытке использования AddIndex я получаю ошибку 'Invalid Index/Tag name. (Неверное имя Индекса/Тэга) Index: cusname'. Но у меня нет никаких проблем с этим именем при использовании DeleteIndex.

Есть глючокс с именемани индексов:

if IndexName = Fieldname then ixCaseSensitive is reqd (по умолчанию)
if IndexName <> Fieldname then ixCaseInsensitive is reqd

Таким образом, вам нужно:

InvTbl.AddIndex('cusname', 'name', [ixCaseInsensitive]);

или

InvTbl.AddIndex('name', 'name', []);

- Mike Orriss [000875]


Использование нумерации в 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);

- Mike Orriss [000973]


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

Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.

Вне 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)
  1. Создаем новый проект.
  2. Располагаем на форме следующие компоненты: - TDatabase, TTable, TDataSource, TDBGrid, and TButton.
  3. Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
  4. Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
  5. Выбираем в поле Driver Name (имя драйвера) пункт STANDARD.
  6. Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).
  7. Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA).
  8. Нажимаем кнопку OK и закрываем окно редактора.
  9. В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'.
  10. В компоненте TDataSource свойству DataSet присваиваем 'Table1'.
  11. В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
  12. Создаем в компоненте TButton обработчик события OnClick.
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Table1.Tablename:= 'CUSTOMER';
    Table1.Active:= True;
    end;
  13. Запускаем приложение.
*** В качестве альтернативы шагам 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
  1. Создаем новый проект.
  2. Располагаем на форме следующие компоненты: - TDatabase, TQuery, TDataSource, TDBGrid, and TButton.
  3. Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
  4. Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
  5. Выбираем в поле Driver Name (имя драйвера) пункт INTRBASE.
  6. Щелкаем на кнопке 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=
  7. Устанавливаем следующие параметры
        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
  8. В компоненте TDatabase свойство LoginPrompt устанавливаем в 'False'. Если в секции перекрытых параметров (Parameter Overrides) задан пароль (ключ PASSWORD) и свойство LoginPrompt установлено в 'False', при соединении с базой данный пароль запрашиваться не будет. Предупреждение: при неправильно указанном пароле в секции Parameter Overrides и неактивном свойстве LoginPrompt вы не сможете получить доступ к базе данных, поскольку нет возможности ввести правильный пароль - диалоговое окно "Ввод пароля" отключено свойством LoginPrompt.
  9. Нажимаем кнопку OK и закрываем окно редактора.
  10. В компоненте TQuery свойству DatabaseName присваиваем 'MyNewAlias'.
  11. В компоненте TDataSource свойству DataSet присваиваем 'Query1'.
  12. В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
  13. Создаем в компоненте 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;
  14. Запускаем приложение.
Пример #3: Ввод псевдонима пользователем

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

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

  1. Выполняем шаги 1-11 из примера #1.
  2. Пишем следующий обработчик события OnClick компонента TButton:
    procedure TForm1.Buttton1Click(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;
  3. Запускаем приложение. [000035]


Информация о псевдонимах BDE

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

Обратите внимание на метод GetAliasParams класса TSession.

Возвращенная строка будет содержать искомый путь.

Я пользуюсь следующей функцией:

uses  DbiProcs, DBiTypes;

function GetDataBaseDir(const Alias : string): String;
(* Возвращает каталог расположения базы данных по заданному псевдониму
(без обратного слеша) *)
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;
[000036]


Отображение всех псевдонимов в ComboBox

Письмо от читателя:

Для отображения всех алиасов в ComboBox1:

//Для этого надо в Uses добавить ExtCtrls

Session.GetAliasNames(ComboBox1.Items);

С уважением,
Громов Роман
GromovRV@Bashneft.Bashnet.ru [000640]


Delphi 1

Изменение псевдонима во время выполнения программы

Тема: Установить путь псевдонима?
От: Vicar Hernandez 71610,3303
К: Eryk Bottomley 100271,47

Как с помощью DELPHI попроще изменить путь псевдонима (Alias Path)?

Вы можете создать виртуальный псевдоним (т.е. не сохраняемый в IDAPI.CFG) с помощью компонента TDataBase... и затем изменить ассоциированный DOS-путь на нужный вам.

Для примера:

var
d : TDatabase;
begin
d := TDatabase.Create(Application);
d.DataBaseName := 'TEST_ALIAS';
d.DriverName := 'STANDARD';
d.Params.Add('PATH=C:\DBDEMOS');
d.Connected := True;
end;

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

Eryk [000707]


Delphi 1

Синтаксис функции DbiAddAlias

DbiAddAlias (пропущено в BDE.HLP & Руководстве пользователя)

Синтаксис:

   DBIResult DbiAddAlias( [hCfg], pszAliasName, pszDriverType, pszParams, bPersistent );
Описание:
   DbiAddAlias добавляет псевдоним в конфигурационный файл, связанный с
   текущим сеансом.
Параметры:
   hCfg              Type: hDBICfg              (Входящий)
      Для BDE 2.5 данный параметр должен быть NULL. Указывает, что
      конфигурация действует в течение текущего сеанса.
      Другие значения для BDE 2.5 не поддерживаются.

   pszAliasName      Type: pCHAR                (Входящий)
      Указатель на имя псевдонима. Это имя нового псевдонима, который
      должен быть добавлен.

   pszDriverType     Type: pCHAR                (Входящий)
      Указатель на тип устройства. Это тип устройства для добавляемого
      псевдонима. Если данный параметр NULL, псевдоним будет добавлен
      для базы данных STANDARD. Если указан szPARADOX, szDBASE или szASCII,
      будет добавлена запись в генератор псевдонимов базы данных STANDARD
      для указания того, что данный тип будет предпочтительным типом
      устройства. Если указано имя устройства, то оно должно существовать
      в измененном файле конфигурации.

   pszParams         Type: pCHAR                (Входящий)
      Указатель на список дополнительных параметров. Данный список
      определяется следующим образом:
      "AliasOption: Option Data[;AliasOption: Option Data][;...]".
      AliasOption должен соответствовать одному из значений, возвращаемому
      DbiOpenCfgInfoList. Для псевдонимов базы данных STANDARD, единственно
      необходимый параметр - PATH, остальные игнорируются (без ошибок).

      Пример 1: Чтобы установить путь для использования базы данных
        STANDARD:
         "PATH:c:\mydata"

      Пример 2: Чтобы установить имя сервера и имя пользователя для
        использования драйвера SQL:
         "SERVER NAME: server:/path/database;USER NAME: myname"

   bPersistent       Type: BOOL                 (Входящий)
      Определяет область действия нового псевдонима.
         TRUE     Сохраняется в файле конфигурации для будующих сеансов.
         FALSE    Для использования только в течение текущего сеанса.
                  Псевдоним удаляется в конце сеанса (или при выходе из
                  программы).

Использование:
   Созданный данной функцией псевдоним будет иметь параметры по умолчанию,
   хранимые в списке параметров драйверов "DB OPEN", если только оне не
   перекрыты в параметре pszParams. Вы можете использовать
   DbiOpenCfgInfoList, чтобы изменить значение по умолчанию после добавления
   псевдонима с помощью DbiAddAlias.

   Для псевдонимов стандартной базы данных все параметры pszParams за
   исключением PATH игнорируются.

Предварительные условия:
   DbiInit должен вызываться до вызова DbiAddAlias.

Возвращаемые значения DBIResult:
   DBIERR_INVALIDPARAM
      Имя псевдонима Null или один из следующих типов pszDriverType:
      szASCII, szDBASE, szPARADOX. В последнем случае используйте
      NULL pszDriverType для указания на базу данных STANDARD.

   DBIERR_NONE
      Псевдоним был успешно добавлен.

   DBIERR_NAMENOTUNIQUE
      Существует другой псевдоним с тем же именем (работает
      когда bPersistent равен TRUE).

   DBIERR_OBJNOTFOUND
      Один (или более) из дополнительных параметров, указанных в
      pszParams не соответствуют правильным типам в секции драйверов
      конфигурационного файла.

   DBIERR_UNKNOWNDRIVER
      Имя устройства в конфигурационном файле при сопоставлении с
      pszDriverType не найдено.

Смотри также:
   DbiInit, DbiOpenCfgInfoList
[000714]


Delphi 1

Добавление псевдонима с помощью функции DbiAddAlias

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;

- Tom Stickle [000765]


Delphi 1

Имитация псевдонима PdoxWIN 'PRIV'

var
d : TDataBase;
begin
d := TDataBase.Create(Application);
d.DataBaseName := 'PRIV';
d.DriverName := 'STANDARD';
d.Params.Add('PATH='+Session.PrivateDir);
d.Connected := True;
end;

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

- Eryk Bottomley [000871]


Delphi 1

Перехват ошибок DBEngine

Ошибки общего характера, типа 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.

Eryk [000567]


Delphi 1

Обработка исключений EDBEngineError

Информация, описывающая условия возникновения ошибки BDE, может быть получена приложением с помощью исключения EDBEngineError. Перехват и обработка в приложениях исключений EDBEngineError осуществляется с помощью конструкции try..except. При наступлении исключения EDBEngineError должен быть создан объект EDBEngineError, различные поля в котором могут быть использованы программистом для определения источника ошибки и принятия решения по исправлению ситуации. Для данного типа исключения может генерироваться более чем одно сообщение об ошибке. Для получения нужной информации необходимо "проиграть" все сообщения.

Вот поля, наиболее соответствующие нашему контексту:

  • ErrorCount: тип Integer; указывает количество ошибок в свойстве Errors; отсчет начинается с нуля.
  • Errors: тип TDBError; набор записей типа структуры, содержащей информацию о каждой специфической сгенерированной ошибке; каждая запись доступна через номер индекса, имеющего тип Integer.
  • Errors.ErrorCode: тип DBIResult; указывает код ошибки BDE для ошибки в текущей записи Errors.
  • Errors.Category: тип Byte; категория ошибки, ссылается на поле ErrorCode.
  • Errors.SubCode: тип Byte; субкод значения ErrorCode.
  • Errors.NativeError: тип LongInt; код удаленной ошибки, возвращаемой сервером; если ноль, то ошибка не является ошибкой сервера; в этом поле возвращается код запроса SQL.
  • Errors.Message: тип TMessageStr; если ошибка является ошибкой сервера, то сообщение сервера содержится в текущей записи Errors; если это не ошибка сервера, то это сообщение об ошибке BDE.
В случае наличия конструкции try..except, объект EDBEngineError создается непосредственно в секции except. После создания объекта исключения все его области становятся доступными, ссылка на объект может передаваться в другую процедуру для детального исследования ошибок. Метод передачи объекта EDBEngineError в специализированную процедуру для приложения предпочтительнее, поскольку делает код приложения более модульным и уменьшает общий объем кода, необходимого для синтаксического анализа объекта и получения информации о возникшей ошибке. В качестве альтернативы можно предложить идею создания специализированного компонента, предусматривающего описанную функциональность; такое решение позволяет распространять созданный в основе компонента код среди нескольких приложений. Приведенный ниже пример демонстрирует создание объекта DBEngineError, передачу его процедуре и синтаксический разбор объекта для получения информации об ошибке.

В конструкции try..except для создания экземпляра DBEngineError необходим синтаксис, показаный ниже:

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
if Edit1.Text > ' ' then begin
Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text);
try
Table1.Post;
except on E: EDBEngineError do
ShowError(E);
end;
end;
end;

В данной процедуре сделана попытка изменить значение поля таблицы и вызвать метод Post соответствующего компонента TTable. Ошибка при попытке отправить измененные данные перехватывается в секции try..except. В случае возникновения EDBEngineError, выполнение передается в секцию except, где происходит создание объекта EDBEngineError (E) и передача его процедуре ShowError. Обратите внимание на то, что в этой секции во внимание берутся только исключения EDBEngineError. В реальной программе код должен содержать проверку на другие типы исключений.

Процедура ShowError в качестве параметра получает ссылку на объект EDBEngineError и "опрашивает" его на предмет наличия информации об ошибках. В приведенном ниже примере информация об ошибках отображается в компоненте TMemo. В реальной жизни отображение ошибок может и не понадобится, но информация о них является логикой работы приложения, расширяющая его функциональность так, чтобы оно могло правильно реагировать на них. Первым шагом необходимо вычислить количество реально произошедших ошибок. Эта величина хранится в свойстве ErrorCounnt. Данное свойство имеет тип Integer и может использоваться для создания цикла, в теле которого можно по очереди получить информацию о каждой ошибке, содержащейся в объекте. В теле цикла поочередно ErrorCount-раз перебираются все содержащиеся в объекте ошибки (как вы помните, каждая ошибка представляет собой запись-элемент свойства Errors), "достается" о них вся информация и помещается в компонент TMemo.

procedure TForm1.ShowError(AExc: EDBEngineError);
var
i: Integer;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('Количество ошибок: ' + IntToStr(AExc.ErrorCount));
Memo1.Lines.Add('');
{Перебираем все записи Errors}
for i := 0 to AExc.ErrorCount - 1 do begin
Memo1.Lines.Add('Сообщение: ' + AExc.Errors[i].Message);
Memo1.Lines.Add(' Категория: ' +
IntToStr(AExc.Errors[i].Category));
Memo1.Lines.Add(' Код ошибки: ' +
IntToStr(AExc.Errors[i].ErrorCode));
Memo1.Lines.Add(' Субкод: ' +
IntTooStr(AExc.Errors[i].SubCode));
Memo1.Lines.Add(' Реальная ошибка: ' +
IntToStr(AExc.Errors[i].NativeError));
Memo1.Lines.Add('');
end;
end;

[000592]


Delphi 1

Автоматический logon к локальной InterBase

Используйте компонент TDatabase. В строках Params пропишите:

     USER NAME=sysdba
     PASSWORD=masterkey
Затем установите свойство компонента TDataBase LoginPrompt в False.

После этого, с помощью свойства DataBaseName, вы должны создать прикладной псевдоним (Alias) и связать TQuery/TTable с вашим компонентом TDataBase. [000517]


Delphi 1

Автоинкрементальные поля и Interbase I

Оказывается, что Interbase триггер "before insert" срабатывает только после того, как запись "запостится" из Delphi приложения. В связи с чем становится невозможным увеличение автоинкрементальных ключевых полей. Есть решение?

Большинство программистов решило эту проблему созданием хранимой процедуры (stored procedure), позволяющей от InterBase получить следующий номер и поместить его в вашу запись посредством метода onBeforePost или onNewRecord. [000559]


Delphi 1

Автоинкрементальные поля и Interbase II

Я пытаюсь сгенерировать последовательный ключ для первичной ключевой колонки, но 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 ^
Steve Koterski (Borland) [000713]


Delphi 1

Автоинкрементальные поля и Interbase III

Я пытаюсь добавить запись в таблицу 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], хотя это то же работает.

- Mike Downey [000872]


Delphi 1

Interbase BLOB-поля

InterBase 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, обозначение его подтипа может отличаться от действительного.

[000639]


Delphi 1

OLE <--> Interbase

Вот как прочесть из таблицы Interbase:

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;

- Rob Minte [000731]


Delphi 2

Автоматический запуск сервера Interbase

Мой InterBase сервер загружается при запуске Win95. Но я не вижу иконки программы в группе автозапуска. Как мне его выключить?

В системных регистрах имеется один ключ:

 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run
Вы можете отключить автоматическую загрузку сервера, удаляя соответствующую переменную.

-Steve Schafer [000962]


Delphi 1

Конфигурирование ODBC

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

Для того, чтобы Borland Database Engine мог пользоваться драйверами ODBC, они должны быть сконфигурированы следующим образом:

  1. Инсталлируйте драйвер и установите его в Панель Управления/ODBC administrator.
    • Если это файл базового драйвера типа dBase, Paradox, Excel, FoxPro и др., то вы должны указать каталог, содержащий ваши файлы.
    • Access и Local Btrieve файлы должны указывать на конкретный файл базы данных (Btreive на File.ddf, Access должен указывать на файл с расширением .MDB).
    • Если это линк (connection) к базе данных, например Oracle, Sybase, Interbase, и др., вы должны указать на этот линк. Обычно транспорт посредством TCPIP, SPX/IPX, NetBEUI и т.п. предусматривается поставщиком программного обеспечения. Каждый драйвер работает с транспортным протоколом по-своему.
  2. Запустите Database Engine Configuration Utility. (BDECFG.EXE)
  3. Выберите New ODBC Driver.
  4. Задайте имя вашему драйверу (к имени автоматически добавится "ODBC_".)
  5. Выберите ваш ODBC Driver из списка Default ODBC Driver List.
  6. Выберите имя источника данных по умолчанию.
  7. Создайте псевдоним (alias), указывающий на установленный вами драйвер.
  8. Установите ссылку с именем псевдонима на ваш драйвер.
Примечание относительно баз данных 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.

Mark Nelson
Delphi Tech Support [000522]


Delphi 1

Конфигурирование ODBC и псевдонима

Конфигурирование драйверов ODBC и псевдонимов

Настройка ODBC в Панели Управления

При инсталляции, Delphi устанавливает в Панель Управления апплет "ODBC" (далее - "настройка ODBC"). "Настройка ODBC" содержит доступные источники данных (драйвера), установленных для использования ODBC. Как вы можете видеть на главной странице "Data Sources", ODBC содержит внушительный набор форматов, которые могут использоваться в Delphi. Дополнительные форматы поддерживаются установленными драйверами и могут быть добавлены с помощью кнопки "Add...".

Для добавления нового или удаления существующего драйвера:

  1. В окне "Data Sources" нажмите кнопку "Drivers...". В появившемся диалоговом окне "Drivers" нажмите кнопку "Add..." и укажите путь к новому драйверу ODBC.
  2. Возвратитесь в окно "Data Sources" и добавьте доступные с новым драйвером источники данных с помощью кнопки "Add...".
  3. Для настройки конкретного источника данных используйте кнопку "Setup...". Функция кнопки "Setup..." меняется с каждым форматом данных. Частенько настройки типа рабочей директории для драйвера настраиваются как раз в этом месте.
Разделы электронной справки доступны для каждой страницы и диалогового окна "Настроки ODBC".

BDE CONFIGURATION UTILITY

После установки драйвера ODBC, запустите BDE Configuration utility для конфигурации BDE для работы с новым драйвером.

  1. На странице драйверов нажмите на кнопку "New ODBC driver".
  2. Появится диалог с заголовком "Add ODBC driver". Опция "SQL link driver" позволяет выяснить, с какими типами баз данных можно работать с помощью данного драйвера ODBC.
  3. Затем выбирайте default ODBC driver (драйвер ODBC по-умолчанию). Выпадающий список содержит список типов файлов, поддерживаемых установленными в системе драйверами ODBC.
  4. Выберите для ODBC-драйвера источник данных по-умолчанию (default data source). Имея уже установленный на шаге 3 драйвер ODBC, список этого combobox'а будет содержать имена источников данных, подходящих для использования с выбранным драйвером.
  5. Нажмите Ok.
  6. Возвратитесь на страницу драйверов, выберите File/Save из главного меню и сохраните данную конфигурацию.
Создание псевдонима в DATABASE DESKTOP

Хотя создать псевдоним ODBC можно и из BDE Configuration utility, Database Desktop предоставляет более комфортное решение.

  1. В меню "File" выберите пункт "Aliases..".
  2. В появившемся диалоге "Alias Manager" нажмите кнопку "New".
  3. Введите имя вашего нового псевдонима в поле редактирования, помеченной как "Database Alias".
  4. Используя выпадающий список "Driver Type" (типы драйверов), выберите драйвер, подходящий для данного псевдонима. Таблицы Paradox и dBase считаются STANDARD. Если в BDE Configuration utility драйвер ODBC был правильно сконфигурирован, то его имя появится в списке.
  5. Дополнительные опции опции могут появляться в зависимости от выбранного типа драйвера.
  6. После завершения всех описанных действий сохраните новый псевдоним, выбрав "Keep New". Затем нажмите "Ok". Появится подсказка, спрашивающая о необходимости сохранения псевдонима в IDAPI.CFG. Выберите "Ok".
Теперь псевдоним будет работать и в Database Desktop, и в Delphi. [000614]


Delphi 1

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'. Работает замечательно.

Надеюсь это поможет... успехов... [000637]


Delphi 1

Установка ODBC/Watcom SQL

...если вам нужно знать, что творится за сценой, нужно просто взглянуть на эти два файла, оба человеко-читаемых, оба расположенных в вашей директории 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 уже более года.

Johannes M. Becher
CODATA GmbH Krefeld, Germany [000638]


Delphi 1

BDE/ODBC/SQL Server 6.0

...хорошо, можете мне не верить, но я могу прикрутить BDE/ODBC/SQL Server 6.0 для моей работы. И даже с той проблемой, с которой вы ко мне обратились (ошибка открытия базы данных), это может работать и у вас.

Шаг #1. Убедитесь в том, что драйвер SQL Server ODBC имеет версию не ниже is 2.50.0121. Это можно сделать двумя путями: запустить ODBC Administrator, щелкнуть на закладке с драйверами, выбрать SQL Server и щелкнуть на кнопке "About". Другой способ немного проще (простите за сарказм после описания вашего способа): вы можете просто сообщить 16-битной Windows о том, что вы работаете с версией драйвера 2.50.0121 ODBC и установить его по умолчанию в параметрах SQL Server!

Это не шутка (!!!). Я говорил по этому поводу с группой поддержки Microsoft, и они сообщили мне, что если я не буду использовать версию 2.50.0121 драйвера ODBC, то я получу кучу проблем, особенно с функциями "Catalog" (которые, как я понимаю, по умолчанию включены в набор функций базы данных). При установке этой версии драйвера, любые попытки "поговорить" с SQL Server через ODBC возвращали ошибку SPXListenForPacket (или типа этой). Я позвонил в группу поддержки Microsoft, на что они ответили: "О, да. Забудьте об этом. Драйвер ODBC не работает с SQL Server 6.0 с параметрами по умолчанию SQL Server 6.0."

Шаг #2. "Сбросьте" размер сетевого пакета, используемого SQL Server 6.0 (установите его равным 512 байтов). Я не помню точное его значение, но вы можете справиться в руководстве по SQL Server 6.0. Надеюсь что помог вам!

Ben [000656]


Delphi 1

Вопросы Delphi/BDE/SQL Links

Объект: SQL Server

Некоторые вопросы, с которыми мне пришлось столкнуться (некоторые из них могут быть решены в самых последних обновлениях и версиях Delphi/BDE/SQL Links):

  1. TStoredProc не может работать с SQL Server 6.0 и ODBC. Delphi передает дополнительный параметр для возвращаемого значения процедуры, который не может "переварить" SQL 6.0. Такая же проблема была и в 4.21, но 4.21 не имел проверку этих параметров. Для использования хранимых процедур вы должны использовать TQuery.

  2. TStoredProc с SQL Links имел ошибку в параметрах строки, заключающуюся в неправильном заполнении максимальной длины управляющих символов. Это калечило хранимые данные и делало так, что результаты, получаемые с любым выражением WHERE и использованием такого параметра никогда не соответствовали ожидаемым и действительным.

  3. TStoredProc не прозрачен между SQL Links и ODBC. Если вы создаете компонент TStoredProc при связи посредством SQL Links, и запустите приложение с использованием соединения ODBC, это работать не будет. Delphi создает два различных (и несовместимых) синтаксиса для возвращаемого значения процедуры. Вы не можете переключаться между SQL Links и ODBC (в любом направлении).

  4. Из-за проблем TStoredProc, описанных выше (и поскольку нам необходимо иметь возможность работы приложений со множеством SQL-серверов), для вызова хранимых процедур мы используем TQuery. Я не могу узнать как мне получить значение выходного параметра от хранимой процедуры, используя TQuery. Соединения ODBC всегда возвращают Null. Соединения SQL Links также возвращают Null или ошибку синтаксиса процедуры. Borland же требует безукоризненной работы. Я надеюсь что это сделать все-же можно, только мне пока не сообщили как. Многие программисты говорят об аналогичных проблемах.

  5. Соединения ODBC игнорируют базу данных, определенную в источнике данных ODBC и всегда подключаются к основной (мастер) базе данных. Если вы определяете базу данных по умолчанию для пользователей SQL Server, она *будет* подключаться. Это проблема, похоже, относится только к драйверам Microsoft ODBC и как с ними работает Delphi. Некоторые сообщают, что драйвер Intersolv работает правильно.

  6. Вы не должны забывать сбрасывать все запросы перед началом нового. SQL Server не допускает множества курсоров в одном соединении с базой данных, так что, если вы начинаете с запроса, возвращающего установленный результат, вам необходимо убедиться, что приложение выбрало все строки (TQuery.Last) перед началом другого запроса. Или перед началом другого запроса не забывайте закрывать предыдущий (TQuery.Close). Если вы не сделаете этого, вы увидете "Connection is in use by another statement" (Соединение используется другим запросом) при вашем следующем запросе.

  7. Тем не менее, если вы вызываете TQuery.Prepare перед запуском вашего запроса, TQuery.Close не закроет соединения. Убей не знаю почему. Я начал получать целую кучу ошибок "Connection is in use by another statement" там, где я закрыл запрос перед началом следующего. Я потратил пару часов прежде чем выяснил, что мой вызов Prepare аннулирует вызов TQuery.Close.

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

    execute pb_creditapp_update(
  :iAPPLICATION_ID,
  :iCURUSER_ID,
  :iNAME,
  :iADDRESS,
  :iCITY,
  и т.д. для нескольких строк.
    TQuery требует несколько секунд, чтобы "заполнить себя". Дело в том, что для каждой SQL-строки, добавляемой к компоненту, TQuery уничтожает свой внутренний список параметров и полностью создает его вновь. Так что, если вы имеете 50 параметров в разных строках, TQuery 50 раз пересоздаст внутренний список параметров.

  9. У меня были проблемы с использованием RAISERROR в качестве исключения в Delphi. Обычно это классно работает. Но если вы используете это в хранимой процедуре после того, как ваша хранимая процедура что-то сделала для установления результата (SELECT), то RAISERROR не возвращается в Delphi в виде исключения (или ODBC, или SQL Links). Visual Basic это "получает" как положено, поэтому я подразумеваю, что это какая-то проблема с BDE. Если вы используете RAISERROR перед любым запросом, который устанавливает результат, то это работает как надо.
[000698]


Delphi 1

Ошибка ODBC SQL Prepare

Тема: Проблема ODBC в Delphi
От: Scott Gammans 71613,1056
...я получил сегодня Delphi, установил и перекомпилил тестовое приложение.

При подключении к источнику данных ODBC, данная последовательность вызывает утечку памяти без возникновения GPF:

 Prepare->ExecSQL->ExecSQL->ExecSQL->...
C установленной Delphi это еще требует подготовку (prepare) каждого запроса:

 Prepare->ExecSQL->Unprepare->Prepare->ExecSQL->Unprepare->...
[000708]


Delphi 1

Получение дескриптора 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 [000853]


Delphi 1

Связь с personal Oracle

Связаться с Personal Oracle - мудреное дело, но оно оказывается очень простым, если знать как...

  1. Personal Oracle должен иметь имя сервера (servername) "2:" (два и точка с запятой)
  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, [000775]


Одной строкой

Связь BDE/Oracle

В SQL*Plus строка соединения - "xxxxxx.yyy"

В BDE это определяется как "@xxxxxx.yyy"

Символ @ является ключом.

-Neil Ferraiuolo [000930]


Одной строкой

Текущий номер записи

Использование GetBookMark, GotoBookMark, и FreeBookMark - предпочтительный путь, если вы хотите сохранить позицию записи и вернуться к ней. Если по некоторой причине вам нужен номер записи (paradox не имеет номер записей, но он имеет номер последовательности), вы должны использовать функцию BDE DbiGetSeqNo.

OAmiry/Borland [000369]


Delphi 1

Вставка новой записи через буфер

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.

- Eryk Bottomley [000870]


Delphi 1

Имя SQL-таблицы

Этот SQL не работает для RequestLive := True : SELECT * FROM DBO.TABLE1

Этот SQL работает для RequestLive := True : SELECT * FROM "DBO.TABLE1"

Помните о том, что кавычки необходимы для обозначения имени таблицы! Также имейте в виду, что поставляемая документация говорит о том, что для таблиц Oracle кавычки не нужны! Неверно, нужны!!! [000325]


Интерактивные 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;

[000377]


Одной строкой

Синтах SQL-функции Substring

Какой синтакс у SQL-функции SUBSTRING()?

SUBSTRING('Delphi - это супер!!!' from 1 to 6)

[000391]


Delphi 1

SQL и расширенные символы

Я использую поле Tmemo.

Это классно работает до тех пор, пока я не использую расширенные символы (с кодом больше 127). При использовании этих символов текст-то я послать могу, но при последующем поиске записи я получаю такое сообщение об ошибке:

"General SQL error : Cannot transliterate character between character sets." (Общая ошибка SQL: не могу сопоставить символ с имеющимися наборами символов).

Я понял, в чем ваша ошибка: вы должны установить встроенный набор символов LIBS в DEFAULT CHARACTER SET ISO8859_1. Когда вы впоследствии создадите таблицу, она будет использовать данный набор символов для создания alfanumeric-данных и Blob-полей. Псевдоним базы данных должен быть установлен на драйвер языка BLLT1FR.

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

Может быть и не стоило публиковать эту информацию, поскольку многие пользователи пользуются локальными драйверами, наборами символов и новой версией SQL, но я посчитал ее ценной, поскольку как раз эта инфорамция в описании и отсутствует. Она присутствует только в LIBS "readme"-файле. [000412]


Delphi 1

SQL в Delphi

Delphi поддерживает статический и динамический SQL. В Delphi имеется объект TQuery, который используется для хранения и выполнения SQL-запросов.

Свойство TQuery SQL содержит текст SQL-запроса, выполняемых TQuery.
Данное свойство имеет тип TStrings, означающее, что оно может хранить в списке целую серию строк. Список ведет себя подобно массиву, но в действительности это специальный класс с уникальными возможностями.

Компонент TQuery позволяет выполнять два типа SQL-запросов:

  • Статические SQL-запросы
  • Динамические SQL-запросы
Статический SQL-запрос устанавливается во время проектирования и не содержит никаких параметров или переменных. Например, следующая строка является статическим SQL-запросом:

SELECT * FROM CUSTOMER WHERE CUST_NO = 1234

Динамический SQL-запрос, или, как его еще называют, параметрический запрос, включает в себя параметры для колонок или имени таблицы. Например, следующая строка является динамическим SQL-запросом:

SELECT * FROM CUSTOMER WHERE CUST_NO = :Number

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

Delphi-приложения могут использовать SQL для получения доступа к следующим БД:

  • Таблицы Paradox или dBASE, использующие локальный SQL. Допустимый синтаксис является подмножеством стандарта ANSI-standard SQL и включает основные SELECT, INSERT, UPDATE, и DELETE запросы. Для получения дополнительной информации о локальном синтаксисе SQL обратитесь к справке Using Local SQL.
  • Базы данных Local InterBase Server, включая Local InterBase Server. Допускаются любые запросы InterBase SQL. Для получения дополнительной информации о синтаксисе и ограничениях обратитесь к электронной справке SQL Statement and Function Reference.
  • Базы данных на удаленных серверах баз данных (только в версии Delphi Client/server). По-видимому вы установили подходящий SQL Link. В SQL серверах допускаются любые стандартные SQL запросы. Для получения дополнительной информации о синтаксисе и ограничениях обратитесь к электронной справке вашего сервера.
Delphi также поддерживает разнородные запросы к более чем одному серверу или типу таблицы (для примера, данные из таблицы Oracle и таблицы Paradox). Для получения дополнительной информации обратитесь к электронной справке Creating Heterogeneous Queries (создание гетерогенных запросов).

Обработка транзаций в приложениях:

Delphi приложения могут управлять транзакциями следующими способами:

  1. Неявно, автоматически стартуя и запуская транзакции, когда приложение пытается передать данные (Post data).
  2. Явно, следующими способами в зависимости от уровня управления, требующемуся вашему приложению:
    • Методы TDatabase StartTransaction, Commit, и Rollback.
    • Это рекомендуемый метод.
  3. Passthrough (транзитная пересылка) SQL в компоненте TQuery. Ваше приложение должно использовать специфически-серверные SQL запросы управления транзакциями, и вы должны понять как управляются транзакции вашим сервером.
OAmiry/Borland [000502]


Одной строкой

SQL outer join

Select * From "TEST.DB" Test Left Outer Join "Emp.DB" Emp
On Test.Emp_ID = Emp.Emp_ID

Вместо Left вы можете также задать Right или Full. [000528]


Delphi 1

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;

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

- Dieter Menne [000732]


Delphi 1

Проблемы StoredProc у SQL server

Обнаруженная мною проблема заключается в ненормальной работе BDE с TStoredProc, когда хранимая процедура SQL получает на входе параметр типа String. Как я понял, BDE/SQL Links перед вызовом хранимой процедуры заносит в строку управляющие символы. Чтобы обойти эту проблему, Borland предлагает использовать TQuery. Конечно, ничего не стоит перевести TStoredProcs в TQuerys (с сохранением полного набора характеристик и без потери скорости), но мне стала интересна причина такого поведения компонента, и я решил покопаться в TStoredProc насколько это было мне возможно и интересно, для чего я добавил дополнительный параметр к хранимой процедуре, позволяющий указывать длину передаваемой процедуре строки. Затем, уже в процедуре, если реальная длина строки оказывалась больше, с помощью дополнительно передаваемого параметра бралась, и в дальнейшем использовалась только левая часть строки, а остальные управляющие символы игнорировались.

Вот пример:

Приведенная ниже процедура SQL Server возвращает 1 если таблица существует, и 2 в противном случае.

CREATE PROCEDURE up_TableExists
  ( @TableName varchar(50), @TableNameLen int = null)
AS
  declare @CleanTblName varchar(50)
  if @TableNameLen is not null
    select @CleanTblName = SubString(@TableName,1,@TableNameLen)
  else
    select @CleanTblName = @TableName
  if EXISTS (SELECT name FROM sysobjects WHERE name = @CleanTblName)
    RETURN 1
  else
    RETURN 2
Поехали...

В Delphi, прежде чем вызвать ExecProc, установите параметр длины строки... вот пример вызова хранимой процедуры в Delphi...

var
sTableName: String;
rc: Boolean;
...
sTableName := 'MyTable';
With StoredProc1 do
begin
. . .
ParamByName('@TableName').AsString := sTableName;
{ обход проблемы: передаем длину строки SQL Server для
обработки хранимой процедурой }
ParamByName('@TableNameLen').AsInteger := Length(sTableName);
Prepare;
ExecProc;
rc := ParamByName('Result').AsInteger = 1;  {rc True если result = 1}
if rc then
....
end;

- David Gecawich [000734]


Delphi 1

SQL: вложенные пробелы

Выполнение SQL с пробелами и специальными символами в имени поля/колонки

Выполнение SQL-запросов в Delphi-компоненте TQuery (или специального средства SQL-запроса в Database Desktop, Visual dBASE или Paradox for Windows) требует специального синтаксиса для любых колонок, содержащих пробелы или специальные символы.

Пользуясь таблицей Biolife.DB из демо-данных Delphi, проиллюстрируем использование любых специфических требований синтаксиса. Запрос SQL Select мог бы быть сформирован следующим образом:

  SELECT
   Species No,
   Category,
   Common_Name,
   Species Name,
   Length (cm),
   Length_In,
   Notes,
   Graphic
  FROM
   BIOLIFE
В нормальной ситуации пробелы в номерах и именах колонок, длина в сантиметрах, круглые скобки и другие символы могут стать причиной синтаксической ошибки.

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

  SELECT
   BIOLIFE."Species No",
   BIOLIFE."Category",
   BIOLIFE."Common_Name",
   BIOLIFE."Species Name",
   BIOLIFE."Length (cm)",
   BIOLIFE."Length_In",
   BIOLIFE."Notes",
   BIOLIFE."Graphic"
  FROM
   "BIOLIFE.DB" BIOLIFE
В приведенном выше примере таблицный псевдоним BIOLIFE используется в качестве ссылки на саму таблицу и располагается перед именем колонки . Данная ссылка может принимать форму имени псевдонима, реального имени таблицы, или ссылаться на имя файла при использовании таблиц dBASE или Paradox. Следующее SQL-выражение должно также хорошо работать.

Примечание: Данное SQL-выражение может использоваться при условии, что необходимый псевдоним уже открыт. В случае TQuery это означает, что псевдоним определен в свойстве DatabaseName.

  SELECT
   BIOLIFE."Species No",
   BIOLIFE.Category,
   BIOLIFE.Common_Name,
   BIOLIFE."Species Name",
   BIOLIFE."Length (cm)",
   BIOLIFE.Length_In,
   BIOLIFE.Notes,
   BIOLIFE.Graphic
  FROM
   BIOLIFE
Если псевдоним недоступен, то для таблицы должен быть определен путь целиком, например, так:

  SELECT
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Species No",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Category",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Common_Name",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Species Name",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Length (cm)",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Length_In",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Notes",
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Graphic"
  FROM
   "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"
Наконец, есть два средства автоматического форматирования специального синтаксиса. Первым является Visual Query Builder, включаемой в версию Client/Server Delphi. Visual Query Builder выполняет такое форматирование автоматически, по мере создания запроса. Другое средство - Database Desktop Show SQL, доступный при создании и редактировании запроса QBE-типа. После выбора пункта меню Query|Show SQL, отображаемый SQL-текст может быть вырезан и вставлен где необходимо.

[000841]


Параметризованные запросы

Создание и использование параметризованных запросов (Parameterized Queries)

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

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

  Select Test."FName", Test."Salary Of Employee"
  From Test
  Where Test."Salary of Employee" > :val
Примечание: Если вы просто пишете имя поля как "Salary of Employee", вы получите ошибку "Capability Not Supported". Это должно быть просто Test."Salary of Employee".

В нашем случае имя переменной "val", но это может быть любое другое (естественно). Затем вы переходите к свойству TQuery's params и устанавливаете параметр "val" в зависимости от требуемого типа. В нашем примере мы используем тип integer.

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

procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
Close;
ParamByName('val').AsInteger := StrToInt(Edit1.Text);
Open;
end;
end;

Примечание: рекомендуем в качестве меры предосторожности разместить приведенный выше код в блоке try..except.

Если в своем запросе вы хотите использовать ключевое слово LIKE, то вы можете сделать это так:

Примечание: Следующий код использует таблицу пользователя, расположенную в каталоге \delphi\demos\data. При этом также возможно использование псевдонима DBDEMOS.

Код SQL для свойства TQuery.SQL:

  SELECT * FROM CUSTOMER
  WHERE Company LIKE :CompanyName
Код Delphi:

procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
Close;
ParamByName('CompanyName').AsString := Edit1.Text + '%';
Open;
end;
end;

Альтернативный способ передачи параметра (с последующим использованием ParamByName) - params[TheParameterNumber].

Вот демонстрация такого способа:

ParamByName('CompanyName').AsString := Edit1.Text + '%';

или, в качестве альтернативы:

Params[0].AsString := Edit1.Text + '%';

Хитрость шаблона - в конкатенирующем знаке процента в конце параметра.

[000843]


Delphi 2

Не работающий SQL OR

Я заполнил таблицу 10 записями и сделал SQL с "OR" (в свойстве "select * from", где acreage=5.5 или acreage=6). Это работает. Затем я возвратился и поместил вторичный индекс в поле acreage - и это НЕ СРАБОТАЛО.

Наличие вторичного индекса не позволяет нормально отработать запросу SQL.

- Chris Hall/Randall Nelson [000982]


Delphi 1

Копирование таблицы с помощью 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;

[000615]


Delphi 1

Проверка наличия IDAPI

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.

[000623]


Delphi 1

Распространение BDE

Следуйте приведенной ниже инструкции для разворачивания 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, удалите дискету из дисковода и перегрузите клиентскую машину.
Если настройки по умолчанию уже где-то используются, произойдут изменения, указанные ниже.

На клиентской машине появятся два новых каталога - \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
[000632]


Delphi 1

Использование 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 [000655]


Delphi 1

Пример DbiAddFilter

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, где определены вызываемые функции и константы.

Mark Erbaugh [000711]


Delphi 1

Огромные LCK-файлы

Если .EXE-файл расположен в том же каталоге, что и таблица Paradox, и флажок Local Share установлен в TRUE, .LCK-файл с каждым запросом растет как на дрожжах. Другая условие - вы имеете соединение посредством DbiOpenTable или TTable.Open.

РЕШЕНИЕ:

  1. Установите частный (private) каталог в какое-нибудь другое место
  2. Переместите .EXE-файл в каталог, отличный от каталога с файлами таблиц
  3. Установите Local Share в FALSE
- Scott Frolich [000772]


Delphi 1

Ограничения IDAPI

Приведенный текст является цитатой из документа Borland TI2751, Jan 23rd, 1995:

Вот ТЕКУЩИЕ максимальные ограничения для некоторых общих объектов IDAPI. В следующей версии они могут быть другими.

48          // Максимальное число клиентов в системе
32          // Максимальное число сеансов для клиента
32          // Максимальное число открытых баз данных для сессии
32          // Максимальное число загруженных драйверов
64          // Максимальное число сеансов для системы
4000        // Максимальное число курсоров для сессии
100         // Максимальное число паролей для сессии
16          // Максимальное число входов в стеке ошибок
127         // Максимальное число блокировок данного типа в данной таблице
            // BLOB дескрипторов на курсор
Paradox: максимально (16, в различное время два BLOB-поля
           таблицы)
dBASE: в различное время два BLOB-поля
           таблицы
- Reinhard Kalinke [000791]


Delphi 1

Локальный общий доступ

...я так понимаю, что LocalShare относится к ситуации, когда другие не-IDAPI приложения могут одновременно иметь доступ к одним и тем же файлам...

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

LOCALSHARE=False говорит BDE о том, что он должен сам решать при необходимости вопрос о блокировке таблицы/записи в типичных ситуациях, например, когда BDE 'думает' что таблица находится на локальном диске он выключает блокировку для увеличения скорости доступа. К сожалению, логические диски общего пользования в сетях 'p-t-p' программно идентифицируются как локальные с предсказуемо липовыми результатами. Установка LOCALSHARE=True заставляет блокирующий механизм 'включаться' для всех дисков и, следовательно, решает эту проблему.

- Eryk Bottomley [000928]


Delphi 1

Конфликт IDAPI German/English

Тема: w/Dtopics
От: Ralph Friedman(Garlin) 100064,3102
К: Walter Schell 100572,272

Walter:

Я просто установил 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 [000958]


Delphi 2

BDE32 приложения в ptp-сети

Использование BDE32-приложений в Peer-To-Peer сети

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

  1. Windows 95
  2. Windows NT
  3. Lantastic
  4. 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, которые необходимо принимать во внимание:
  1. Использование только 32-битных приложений BDE.
  2. Использование только 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-битные приложения:

  1. В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
  2. Не используйте UNC-имена.
  3. Не используйте таблицы с длинными именами файлов.
  4. Убедитесь в том, что все клиенты подключены к одному и тому же каталогу на сервере.
Только 32-битные приложения:
  1. В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
  2. Для получения доступа к сетевому каталогу и каталогу с таблицами используйте 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)
- Scott Frolich [000981]


Delphi 2

Изменение данных в Delphi 2 (BDE)

...из исходного кода VCL я обнаружил, что при назначении значения DB-полю, имеющему строковый тип, значение "проходит" через функцию ANSItoNative, что может привести к изменению (порче) ASCII-данных. Вот так...

Как 16-, так и 32-битные версии IDAPI.CFG устанавливаются с драйвером языка Paradox 'ascii'.

Я создал простое приложение, записывающее в db-поле значения ASCII в диапазоне 0-255 и затем проверяющее их на предмет появившихся различий..... различия между 16- и 32-битной версией не так велики... для примера... в первых 130 значениях получается следующее преобразование:

 16-бит: 21->182 22->167 31->33 130->128
 32-бит:                        130->128
Очевидно достаточно просто "исправить" 32-битные приложения, чтобы добиться такого же результата, что и получаемые 16-битными приложениями, НО я не уверен что решив проблему на моем PC, я решу ее у остальных пользователей, поскольку могут отличаться установки, драйверы языка... и пр.

После того как я проверил все возможные варианты, я составил таблицу и занес туда пять возможных значений, которые могут отличаться под Delphi2 и Delphi1:

 Значение ASCII    Delphi1     Delphi2
       21            182         21
       22            167         22
       33             31         33
      132            102        132
      255            121        255
- Rob Edgar [000983]


Delphi 2

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);

- Mark Edington [000984]


Delphi 2

Демонстрация обратного вызова 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 [000985]


Получение идентификатора диска

Как получить идентификатор находящегося в CD-ROM'е аудио-компакта?

const
MCI_INFO_PRODUCT              = $00000100;
MCI_INFO_FILE                 = $00000200;
MCI_INFO_MEDIA_UPC            = $00000400;
MCI_INFO_MEDIA_IDENTITY       = $00000800;
MCI_INFO_NAME                 = $00001000;
MCI_INFO_COPYRIGHT            = $00002000;

{ блок параметров для командного сообщения MCI_INFO }
type
PMCI_Info_ParmsA = ^TMCI_Info_ParmsA;
PMCI_Info_ParmsW = ^TMCI_Info_ParmsW;
PMCI_Info_Parms  = PMCI_Info_ParmsA;
TMCI_Info_ParmsA = record
dwCallback: DWORD;
lpstrReturn: PAnsiChar;
dwRetSize: DWORD;
end;
TMCI_Info_ParmsW = record
dwCallback: DWORD;
lpstrReturn: PWideChar;
dwRetSize: DWORD;
end;
TMCI_Info_Parms = TMCI_Info_ParmsA;

Идентификатор возвращается функцией MCI_INFO_MEDIA_IDENTITY в виде строки с десятичным числом. Для получения дополнительной информации обратитесь к электронной справке (Win32 и компонент TMediaPlayer).

Исправления

// метка диска
procedure GetDriveInfo(VolumeName: string; var VolumeLabel, SerialNumber, FileSystem: string);
var
VolLabel, FileSysName :array [0..255] of char;
SerNum :pdword;
MaxCompLen, FileSysFlags :dword;
begin
New(SerNum);
GetVolumeInformation(PChar(VolumeName), VolLabel, 255, SerNum, MaxCompLen, FileSysFlags, FileSysName, 255);
VolumeLabel:=VolLabel;
SerialNumber:=Format('%x',[SerNum^]);
FileSystem:=FileSysName;
Dispose(SerNum);
end;

// далее
var
VolLabel, SN, FileSystem, S : string;
begin
s := 'g:\';             // имя CD дисковода
GetDriveInfo(S, VolLabel, SN, FileSystem);

получаем:

VolLabel   - 'ARMSTRONG' // метка диска
SN         -  B5FF77AD   // номер серийный
FileSystem -  CDFS       // тип файловой системы
Работает не только для CD для всех типов дисков ... Далее:

// метка диска
procedure GetAllDrive(Sender: TObject);
var
i, mask : integer;
s : string;
begin
mask := GetLogicalDrives; i := 0;
while mask<>0 do
begin
s:= chr( ord('a') + i ) + ':\';
if (mask and 1) <> 0 then
case GetDriveType(PChar(s)) of
0               : ListBox1.Items.Add(s + ' unknown.');
1               : ListBox1.Items.Add(s + ' not exist.');
DRIVE_REMOVABLE : ListBox1.Items.Add(s + ' removable.'); // floppy,zip
DRIVE_FIXED     : ListBox1.Items.Add(s + ' fixed.');
DRIVE_REMOTE    : ListBox1.Items.Add(s + ' network.');
DRIVE_CDROM     : ListBox1.Items.Add(s + ' CD-ROM.');
DRIVE_RAMDISK   : ListBox1.Items.Add(s + ' RAM.');
end;
inc(i); mask := mask shr 1;
end;
end;

В ListBox1 получаем все диски на данном компьютере.

Whith best regards Vasili Pincuk. | ICQ 10558844
http//www.geocities.com/pvasili   | E-mail: pvasili@geocities.com
[000037]


Контроль джойстика в Delphi

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

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) модулей. [000184]


Низкоуровневые процедуры обработки звука

Ниже приведен код, обрабатывающий аудиосигнал, получаемый со входа звуковой карты (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 477576218068StartRecord : 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.

[000242]


Извлечение звуков из системного динамика под Windows 95 I

Я применяю следующий код:

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;

Под WinNT вы можете использовать Beep(Tone, Duration) (задавать тон и продолжительность звучания). [000245]


Delphi 1

Извлечение звуков из системного динамика под Windows 95 II

Вот мой старый способ, которым я извлекал звуки в 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 [000757]


Формат 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-битных файлов сделайте соответствующие изменения.

[000246]


Delphi 1

Создание пустого 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 [000825]


Открытие и закрытие привода CD-ROM

Есть ли Win32 API функция, позволяющая не только открыть НО И ЗАКРЫТЬ CD-ROM? Хотелось бы не тянуться ручками к РС, а нажать мышкой на кнопку. Компонентом TMediaPlayer пользоваться не хочу, тем более компакт он может только извлечь...

Для открытия CD-ROM:

mciSendString('Set cdaudio door open wait', nil, 0, handle);

Для закрытия CD-ROM:

mciSendString('Set cdaudio door closed wait', nil, 0, handle);

Nomadic добавляет свой способ открытия CD-ROM:

mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

Не забудьте включить MMSystem в список используемых модулей (uses).

[000038]


CPU Speed routine

Пришло мне письмо от Alex Novikov, где был вложен только код. К сожалению, авторство кода мне установить не удалось, хотя сам код потрясающий в своей простоте!

//
// Determinate CPU Freq
//
//

 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]);
[000381]


Работа с портами микропроцессора

Пришло мне письмо от 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.
[000083]


Получение информации о процессоре

Пришло мне письмо от Igor Popov, где он пишет:

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

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.
[000778]


Форматы бумаги

Вот пример, выводящий список форматов бумаги для принтера, установленного по умолчанию:

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;

[000095]


Управляющие коды принтера

Как мне послать на принтер управляющие коды принтера (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.
[000205]


Настройки принтера

Ниже приведены некоторые участки кода, позволяющие изменять настройки принтера. Тот код, который позволяет менять установки, позволяет также вам узнать принцип управления настройками. Смотри документацию по структурам 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;

[000206]


Печать повернутого текста

Решение 1

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;

Решение 2

Вот как я решил эту проблему:

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;

Решение 3

Некоторое время я делал так: я создавал шрифт, выбирал его в 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;

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

Решение 4

Приведенное выше решение (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;

[000207]


Растягивание изображения при печати

Я пишу программу, которая печатает изображение на принтере с помощью объекта 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;

[000208]


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

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

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

procedure AngleTextOut(CV: TCanvas; const sText: String; x, y, angle:integer);
var
LogFont: TLogFont;
SaveFont: TFont;
procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
R: TRect;
begin
Printer.BeginDoc;  // **
with Printer do
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
R := Rect(0, 0, Image1.Picture.Width * ScaleX,
Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(R, Image1.Picture.Graphic);  // **
finally
EndDoc;  // **
end;
end;

[000209]


Сброс на печать текстового файла

Используйте CreateFile для получения дескриптора LPT1

LPTHandle := CreateFile( 'LPT1',GENERIC_WRITE,
0, PSecurityAttributes(nil),
OPEN_EXISTING, FILE_FLAG_OVERLAPPED,
0);

Затем используйте WriteFile для посылки строки символов или сделайте так:

While not
TransmitCommChar( LPTHandle, CharToSend ) do
Application.ProcessMessages;

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

[000210]


Построчная печать

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

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

Я создал клон объекта TPrinter, назначение которого вы поймете ниже. Это работает со всеми матричными принтерами.

Вот пример объекта:

var Myprinter : TRawPrinter;
oldprinter : TPrinter;
begin
MyPrinter:=TRawPrinter.Create;
oldprinter:=setprinter(MyPrinter);
try
if Printdialog1.execute then
begin
myprinter.startraw;
myprinter.write('khsdhskhkshdksd');
myprinter.writeln;
myprinter.endraw;
end
finally
setprinter(oldprinyter);
myprinter.free;
end
end;

Вот пример использования объекта:

unit Rawprinter;

interface
uses printers,windows;

type TRawprinter =class(TPrinter)
public
dc2 : HDC;
procedure startraw;
procedure endraw;
procedure write(const s : string);
procedure writeln;
end;

implementation
uses sysutils,forms;

function AbortProc(Prn: HDC; Error: Integer): Bool; stdcall;
begin
Application.ProcessMessages;
Result := not Printer.Aborted;
end;

type
TPrinterDevice = class
Driver, Device, Port: String;
constructor Create(ADriver, ADevice, APort: PChar);
function IsEqual(ADriver, ADevice, APort: PChar): Boolean;
end;

constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar);
begin
inherited Create;
Driver := ADriver;
Device := ADevice;
Port := APort;
end;

function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean;
begin
Result := (Device = ADevice) and (Port = APort);
end;

procedure TRawprinter.startraw;
var
CTitle: array[0..31] of Char;
CMode : Array[0..4] of char;
DocInfo: TDocInfo;
r : integer;
begin
StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
StrPCopy(CMode, 'RAW');
FillChar(DocInfo, SizeOf(DocInfo), 0);
with DocInfo do
begin
cbSize := SizeOf(DocInfo);
lpszDocName := CTitle;
lpszOutput := nil;
lpszDatatype :=CMode;
end;
with TPrinterDevice(Printers.Objects[PrinterIndex]) do
begin
DC2 := CreateDC(PChar(Driver), PChar(Device), PChar(Port), nil);
end;
SetAbortProc(dc2, AbortProc);
r:=StartDoc(dc2, DocInfo);
end;

procedure TRawprinter.endraw;
var r : integer;
begin
r:=windows.enddoc(dc2);
end;

type passrec = packed record
l : word;
s : Array[0..255] of char;
end;
var pass : Passrec;
procedure TRawprinter.write(const s : string);
begin
pass.l:=length(s);
strpcopy(pass.s,s);
escape(dc2,PASSTHROUGH,0,@pass,nil);
end;

procedure TRawprinter.writeln;
begin
pass.l:=2;
strpcopy(pass.s,#13#10);
escape(dc2,PASSTHROUGH,0,@pass,nil);
end;

end.

[000211]


Хитрости печати

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

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;

[000212]


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), вам возможно понадобиться добавить пробелы в начале и в конце передаваемых данных, чтобы отделить ваши данные от данных драйвера печати.

(Postscript - зарегистрированная торговая марка Adobe Systems Incorporated)

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.

[000213]


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

Приведенный ниже модуль демонстрирует принцип использования 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.

[000214]


Размер полей при печати

Мне необходимо получить значения (лево, право, верх, низ) "непечатаемой области" принтера.

Из статьи Delphi Developer "Take Control of your printer with a custom Delphi Class":

Чтобы получить левое и верхнее поле принтера, используйте Windows Escape функцию с параметром GETPRINTINGOFFSET.

var
pntMargins : TPoint;
begin
{ @ означает " адрес переменной" }
Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins);
end;

Получить размер правого и нижнего поля не так просто. Просто не существует необходимого эквивалента при вызове Escape функции. Но вы можете узнать эти значения, получив физическую ширину (physWidth) и высоту (physHeight) бумаги, печатаемую ширину (PrintWidth) и высоту (PrintHeight) страницы и выполнив несложные арифметические операции:

RightMargin    := physWidth  - PrintWidth  - LeftMargin
BottomMargin := physHeight - PrintHeight - TopMargin

Физический размер страницы можно получить с помощью Escape-функции, но на этот раз с использованием параметра GETPHYSPAGESIZE. Указатель pntPageSize содержит ширину страницы в pntPageSize.x и ее высоту в pntPageSize.y

var
pntPageSize : TPoint;
begin
Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize);
end;

[000215]


Изменение свойств печати во время ее выполнения

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

(В совете также приведен пример изменения поддона с бумагой...)

*** ШАГИ ***

  1. Создайте копию модуля Printers.pas и переименуйте его в NewPrint.pas.

    ***НЕ делайте изменения в самом модуле Printers.pas, если вы сделаете это, то получите во время компиляции приложения ошибку "Unable to find printers.pas" (не могу найти printer.pas). (Я уже получае ее, поэтому и упоминаю об этом здесь...)***

  2. Переместите модуль NewPrint.pas в директорию Lib.

     (Используйте "C:\Program Files\Borland\Delphi Х\Lib" )

  3. Измените ИМЯ МОДУЛЯ на NewPrint.pas

    с:

    unit Printers

    на:

    unit NewPrint

  4. Добавьте декларацию следующего PUBLIC метода класса TPrinter в секции Interface модуля NewPrint.pas:

    procedure NewPageDC(DM: PDevMode);

  5. Добавьте следующую процедуру в секцию реализации 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;

  6. Вместо добавления "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... Если вы имеете любые комментарии или улучшения,
    не постесняйтесь отправить их мне...

    ************************************************************}

    [000216]


Печать ячеек

У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?

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

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 [000380]


Delphi 1

Метрики принтера

При печати с помощью 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 - это высота шрифта для устройства с разрешением 96DPI (например, ваш экран). Попробуйте назначить величину 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;
[000398]


Диалог прекращения печати

Как мне создать диалог прекращения печати при работе с 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). [000408]


Delphi 1

Прерывание работы принтера

...да, это известная проблема. При вызове Printer.Abort должен вызываться код

WinProcs.AbortProc(Printer.Handle)

но этого не происходит. Вызывайте это сами каждый раз при использовании Printer.Abort. [000459]


Delphi 1

Печать всей формы

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.

[000529]


Delphi 1

Печать содержимого 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);

[000539]


Delphi 1

Печать текста в обход 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 [000610]


Delphi 1

Печать на любом принтере

Как лучше всего убедиться в том, что текст на странице расположен правильно вне зависимости от принтера, версии windows и т.п.?

Есть пара вызовов принтерных Escape-функций API, возвращающих физический размер страницы и отступ от края при печати (верх лево). Используя это, вы можете убедиться в том, печать начинается в одном и том же месте реального листа. Примечание: тем не менее, вы все еще зависите от точности принтера и драйвера, на практике это может вылиться в разброс 1-2 мм.

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

var PhysSize, PrintingOffset : TPoint ;
begin
Escape( Printer.Handle, GetPhysPageSize, 0, NIL, @PhysSize ) ;
Escape( Printer.Handle, GetPrintingOffset, 0, NIL, @PrintingOffset ) ;

PhysSize и PrintingOffset теперь устанавливаются в единицах устройства, т.е. в пикселях принтера. Для преобразования мм в единицы устройства используйте следующий код:

xDevUnits := MulDiv( XXXmm,
GetDeviceCaps( Printer.Handle, HORZRES ),
GetDeviceCaps( Printer.Handle, HORZSIZE ) ) ;
yDevUnits := MulDiv( YYYmm,
GetDeviceCaps( Printer.Handle, VERTRES ),
GetDeviceCaps( Printer.Handle, VERTSIZE ) ) ;

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

Mike Scott. [000716]


Delphi 1

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

Может ли мне кто-либо сказать, как с помощью TPrinter сделать следующее?:

  1. Замена исходного Paper Bin страницей. Создание отчета, который нужно переключать между двумя бункерами (некоторым страницам отчета нужно работать с другим бункером, например бланки писем и пр.).
  2. Печать нескольких копий отчета. Для этого желательно использовать диалог настройки принтера, но это, похоже, не работает.
То, что вы собираетесь делать, возможно с помощью структуры TDevMode, получив к которой доступ, можно делать необходимые вам изменения. Структура TDevMode имеет все необходимые для настройки принтера поля и позволяет сделать любые настройки не обращаясь к диалогу настройки принтера.

Вот пример одного из моих компонентов, инкапсулирующий вышесказанную функциональность:

procedure TCrpePrinter.GetCurrentPrinter;
var
lpDevice: PChar;
lpDriver: PChar;
lpPort: PChar;
Handle: THandle;
begin
lpDevice := StrAlloc(255);
lpDriver := StrAlloc(255);
lpPort := StrAlloc(255);

try
Printer.GetPrinter(lpDevice,lpDriver,lpPort,Handle);
if Handle <> 0 then    { если это не 0, то мы имеем указатель на структуру устройства}
begin
FDevMode := Ptr(Handle,0);      {Получаем дескриптор структуры устройства}
FDevice := StrPas(lpDevice);
FDriver := StrPas(lpDriver);
FPort := StrPas(lpPort);
end
else
begin
Printer.PrinterIndex := Printer.PrinterIndex;    {Этим мы пытаемся осуществить инициализацию}
Printer.GetPrinter(lpDevice,lpDriver,lpPort,Handle);
if Handle <> 0 then
begin
FDevMode := Ptr(Handle,0);
FDevice := StrPas(lpDevice);
FDriver := StrPas(lpDriver);
FPort := StrPas(lpPort);
end
else
begin
FDevMode := nil;
raise ECrpe.Create('Ошибка загрузки драйвера принтера');
end;
end;
finally
StrDispose(lpDevice);
StrDispose(lpDriver);
StrDispose(lpPort);
end;
end;

Изменение лотка и количества копий:

dmCopies := 2;
dmDefaultSource := 2;  {Нижний лоток}

Как только вы получите указатель на структуру devmode, вы вправе делать изменения любых полей. Говорят, могут быть проблемы при изменении лотков во время печати, но сам я не пробовал менять эти поля в структуре DevMode.

- Jeff Fisher [000822]


Как мне проверить готовность диска 'a:'? I

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;

С уважением, Галимарзанов Фанис [000076]


Как мне проверить готовность диска 'a:'? II

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;

[000527]


Серийный номер тома

Как с помощью Delphi 2.0 мне получить серийный номер винчестера?

Попробуй это:

procedure TForm1.Button1Click(Sender: TObject);
var
SerialNum : dword;
a, b : dword;
Buffer  : array [0..255] of char;
begin
if GetVolumeInformation('c:\', Buffer, SizeOf(Buffer), @SerialNum, a, b, nil, 0) then
Label1.Caption := IntToStr(SerialNum);
end;

Исправленную версию прислал:

Алексей Коган
FIDOnet 2:5064/7.69
Russia, Stavropol
Andy Dmitriev дополняет:

Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется... Определение серийного номера винчестера несколько сложнее, я встречал этот пример в одной из конференций, да и то оно не работало под NT/2000, кажется. В любом случае оглавление надо поправить, чтобы не дезинформировать читателей.

Поправляю... [000125]


Delphi 1

Управление метками томов дисков

Управление метками томов дисков из Delphi-приложений

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию 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 *** }

[000628]


Звуковой сигнал при нажатии <ENTER>

procedure TForm1.EditKeyPress(Sender: TObject; var Key:Char);
begin
if Key = Chr(VK_RETURN) then
begin
Perform(WM_NEXTDLGCTL,0,0);
key:= #0;
end;
end;
[000137]


Недоступность комбинаций alt-tab и ctrl+esc I

procedure TurnSysKeysOff;
var
OldVal : LongInt;
begin
SystemParametersInfo (97, Word (True), @OldVal, 0)
end;

procedure TurnSysKeysBackOn;
var
OldVal : LongInt;
begin
SystemParametersInfo (97, Word (False), @OldVal, 0)
end;
[000138]


Недоступность комбинаций alt-tab и ctrl+esc II

Subfire советует:

program small;

{автор Richard Leigh, Deakin Univesity 1997}

Dummy : integer;
begin

Dummy := 0;
{Отключаем ALT-TAB}
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
{Отключаем CTRL-ALT-DEL}
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
end.

Великолепный способ!!! Хочу добавить, что он спасает не только от ALT-TAB, CTRL-ALT-DEL но и от CTRL-ESC и клавишы вызова меню из кнопки пуск (#91 - Win95 Keyb), что в сочетании с убиранием с экрана кнопки пуск создает классный эффект :) Распространенный вопрос: а как все назад-то вернуть? Вот ответ:

//Включаем системную обработку
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 0, 0, 0);
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 0, 0, 0);

А вообще посмотрите Windows SDK SystemParametersInfo
Много интересного.... [000901]


Как мне определить нажатие клавиш со стрелками?

Используя событие KeyDown или KeyUp протестируйте это для VK_LEFT, VK_RIGHT и др.

[000139]


Перехват (Hook) клавиатуры (программа Sendkeys)

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

library Sendkey;

{Данный код написан по мотивам книги "Delphi Developer's Guide"
авторов Xavier Pacheco и Steve Teixeira.}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, KeyDefs;

type
{ Коды ошибок }
TSendKeyError = (sk_None, sk_FailSetHook, sk_InvalidToken, sk_UnknownError);

{ исключения }
ESendKeyError = class(Exception);
ESetHookError = class(ESendKeyError);
EInvalidToken = class(ESendKeyError);

{ потомок TList, который знает как избавляться от своего содержания }
TMessageList = class(TList)
public
destructor Destroy; override;
end;

destructor TMessageList.Destroy;
var
i: longint;
begin
{ освобождаем все записи сообщений перед тем как разрушить список }
for i := 0 to Count - 1 do
Dispose(PEventMsg(Items[i]));
inherited Destroy;
end;

var
{ глобальные переменные для DLL }
MsgCount: word;
MessageBuffer: TEventMsg;
HookHandle: hHook;
Playing: Boolean;
MessageList: TMessageList;
AltPressed, ControlPressed, ShiftPressed: Boolean;
NextSpecialKey: TKeyString;

function MakeWord(L, H: Byte): Word;
{ макрос создает число из самого большого и самого маленького байтов }
inline(
$5A/            { pop dx }
$58/            { pop ax }
$8A/$E2);       { mov ah, dl }

procedure StopPlayback;
{ Снимаем перехват и наводим порядок }
begin
{ если перехват к настоящему времени активен, отключаем его }
if Playing then
UnhookWindowsHookEx(HookHandle);
MessageList.Free;
Playing := False;
end;

function Play(Code: integer; wParam: word; lParam: Longint): Longint; export;
{ Это функция-оболочка возвращает JournalPlayback. Вызывается системой во время }
{ опроса аппаратных событий. Параметр Code указывает что нужно делать. }
 begin
case Code of

hc_Skip: begin
{ hc_Skip пропускает очередное сообщение из нашего списка. Если мы }
{ в конце списка, это хорошо, снимаем захват JournalPlayback }
{ в данном месте кода. }
{ увеличиваем счетчик сообщений }
inc(MsgCount);
{ проверка воспроизведения всех сообщений }
if MsgCount >= MessageList.Count then
StopPlayback
else
{ копируем очередное сообщение из списка в буфер }
MessageBuffer := TEventMsg(MessageList.Items[MsgCount]^);
Result := 0;
end;

hc_GetNext: begin
{ hc_GetNext нужен для заполнения wParam и lParam соответствующими }
{ значениями, необходимыми для воспроизведения сообщения. НЕ СНИМАЙТЕ }
{ захват в этом участке кода. Возвращаемая величина указывает время, }
{ в течение которого Windows должна воспроизвести сообщение. Мы }
{ возвращаем 0 для того, чтобы это было обработано немедленно. }
{ перемещаем сообщение в буфер для очереди сообщений }
PEventMsg(lParam)^ := MessageBuffer;
Result := 0 { немедленная обработка }
end

else
{ если Code не hc_Skip или hc_GetNext, то вызываем следующий hook в цепочке }
Result := CallNextHookEx(HookHandle, Code, wParam, lParam);
end;
end;

procedure StartPlayback;
{ Инициализируем глобальные и вешаем hook }
begin
{ захватываем из списка первое сообщение и помещаем }
{ в буфер, если hc_GetNext получено перед hc_Skip }
MessageBuffer := TEventMsg(MessageList.Items[0]^);
{ инициализируем счетчик сообщений }
MsgCount := 0;
{ инициализируем флаги клавиш Alt, Control и Shift }
AltPressed := False;
ControlPressed := False;
ShiftPressed := False;
{ вешаем hook! }
HookHandle := SetWindowsHookEx(wh_JournalPlayback, Play, hInstance, 0);
if HookHandle = 0 then
raise ESetHookError.Create('Не могу повесить hook')
else
Playing := True;
end;

procedure MakeMessage(vKey: byte; M: word);
{ процедура создает запись TEventMsg, эмулирующую нажатие клавиши и }
{ добавляет это к списку сообщений }
var
E: PEventMsg;
begin
New(E);                                 { выделяем память под запись сообщения }
with E^ do begin
Message := M;                         { устанавливаем поле сообщения }
{ больший байт ParamL является кодом vk, меньший - кодом сканирования }
ParamL := MakeWord(vKey, MapVirtualKey(vKey, 0));
ParamH := 1;                          { счетчик повторов равен 1 }
Time := GetTickCount;                 { устанавливаем время }
end;
MessageList.Add(E);
end;

procedure KeyDown(vKey: byte);
{ Генерируем KeyDownMessage }
begin
{ не генерим клавишу "sys" (F10), если нажата клавиша Ctrl (одна из причуд Windows) }
if (AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')])) or
(vKey = vk_Menu) then
MakeMessage(vKey, wm_SysKeyDown)
else
MakeMessage(vKey, wm_KeyDown);
end;

procedure KeyUp(vKey: byte);
{ Генерируем сообщение KeyUp }
begin
{ не генерим клавишу "sys" (F10), если нажата клавиша Ctrl (одна из причуд Windows) }
if AltPressed and (not ControlPressed) and (vKey in [Ord('A')..Ord('Z')]) then
MakeMessage(vKey, wm_SysKeyUp)
else
MakeMessage(vKey, wm_KeyUp);
end;

procedure SimKeyPresses(VKeyCode: Word);
{ Данная функция имитирует нажатие клавиши, передаваемой ей в качестве параметра, }
{ учитывая текущий статус клавиш Alt, Control и Shift }
begin
{ нажимаем клавишу Alt, если выставлен соответствующий флаг }
if AltPressed then
KeyDown(vk_Menu);
{ нажимаем клавишу Control, если выставлен соответствующий флаг }
if ControlPressed then
KeyDown(vk_Control);
{ если shift не нажат, или не нажаты клавиши shif и control... }
if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then
KeyDown(vk_Shift);    { ...нажимаем shift }
KeyDown(Lo(VKeyCode));  { нажимаем клавишу down }
KeyUp(Lo(VKeyCode));    { отпускаем клавишу }
{ если shift нажат, или не нажаты клавиши shif и control... }
if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or ShiftPressed then
KeyUp(vk_Shift);      { ...отпускаем shift }
{ если флаг shift установлен, сбрасываем его }
if ShiftPressed then begin
ShiftPressed := False;
end;
{ Отпускаем клавишу Control, и если флаг клавиши был установлен, сбрасываем его }
if ControlPressed then begin
KeyUp(vk_Control);
ControlPressed := False;
end;
{ Отпускаем клавишу Alt, и если флаг клавиши был установлен, сбрасываем его }
if AltPressed then begin
KeyUp(vk_Menu);
AltPressed := False;
end;
end;

procedure ProcessKey(S: String);
{ Данная функция выполняет разбор каждого символа в строке для создания списка сообщений }
var
KeyCode: word;
Key: byte;
index: integer;
Token: TKeyString;
begin
index := 1;
repeat
case S[index] of

KeyGroupOpen : begin
{ Это начало специального признака! }
Token := '';
inc(index);
while S[index] <> KeyGroupClose do begin
{ добавляем к признаку до тех пор, пока не столкнемся с символом окончания признака }
Token := Token + S[index];
inc(index);
{ убеждаемся, что признак не слишком длинный }
if (Length(Token) = 7) and (S[index] <> KeyGroupClose) then
raise EInvalidToken.Create('Незакрытая скобка');
end;
{ ищем признак в массиве, в случае удачи }
{ параметр Key будет содержать код vk }
if not FindKeyInArray(Token, Key) then
raise EInvalidToken.Create('Неверный признак');
{ эмулируем последовательность нажатия клавиш }
SimKeyPresses(MakeWord(Key, 0));
end;

AltKey : begin
{ устанавливаем флаг клавиши Alt }
AltPressed := True;
end;

ControlKey : begin
{ устанавливаем флаг клавиши Control }
ControlPressed := True;
end;

ShiftKey : begin
{ устанавливаем флаг клавиши Shift }
ShiftPressed := True;
end;

else begin
{ Была нажата клавиша с нормальным символом }
{ конвертируем символ в число типа word, содержащее наибольший байт }
{ статуса shift и наименьший байт кода vk }
KeyCode := vkKeyScan(MakeWord(Byte(S[index]), 0));
{ эмулируем последовательность нажатия клавиш }
SimKeyPresses(KeyCode);
end;
end;
inc(index);
until index > Length(S);
end;

function SendKeys(S: String): TSendKeyError; export;
{ Это первая точка входа. Базируясь на входном параметре - строке  }
{ S, данная функция создает список keyup/keydown-сообщений, вешает }
{ hook на JournalPlayback, и повторяет сообщения нажатий клавиш.   }
var
i: byte;
begin
try
Result := sk_None;                   { успешный прием }
MessageList := TMessageList.Create;  { создаем список сообщений }
ProcessKey(S);                       { создаем сообщения из строки }
StartPlayback;                       { вешаем хук и воспроизводим сообщения }
except
{ при возникновении исключения возвращаем код ошибки и наводим порядок }
on E:ESendKeyError do begin
MessageList.Free;
if E is ESetHookError then
Result := sk_FailSetHook
else if E is EInvalidToken then
Result := sk_InvalidToken;
end
else
{ Перехват дескрипторов всех объектов исключений гарантирует, }
{ что исключение не попадет в стек приложения }
Result := sk_UnknownError;
end;
end;

exports
SendKeys index 1;

begin end
[000140]


Перехват (Hook) клавиатуры (программа Sendkeys) - Полная версия

Вот она! Работающая! С комментариями! Полная версия! Привожу код полностью. Автор Bogachev. Большое человеческое ему спасибо. Старую версию на всякий случай оставляю, авось пригодится.

SendKey - DLL-ка
Project1 - Управляющая программа

Project1.dpr

program Project1;

uses
Forms,
Unit1 in '..\Hooks1\Unit1.pas' {Form1};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

SendKey.dpr

library SendKey;

uses
SysUtils, Classes, Windows, Messages;

const
{пользовательские сообщения}
wm_LeftShow_Event = wm_User + 133;
wm_RightShow_Event = wm_User + 134;
wm_UpShow_Event = wm_User + 135;
wm_DownShow_Event = wm_User + 136;

{handle для ловушки}
HookHandle: hHook = 0;

var
SaveExitProc : Pointer;

{собственно ловушка}
function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint;stdcall; export;
var H: HWND;
begin
{если Code>=0, то ловушка может обработать событие}
if (Code >= 0) and (lParam and $40000000 = 0)
then begin
{ищем окно по имени класса и по заголовку
(Caption формы управляющей программы должен быть равен 'XXX' !!!!)}
H := FindWindow('TForm1', 'XXX');

{это те клавиши?}
Case wParam of
VK_Left: SendMessage(H, wm_LeftShow_Event, 0, 0);
VK_Right: SendMessage(H, wm_RightShow_Event, 0, 0);
VK_Up: SendMessage(H, wm_UpShow_Event, 0, 0);
VK_Down: SendMessage(H, wm_DownShow_Event, 0, 0);
end;
{если 0, то система должна дальше обработать это событие}
{если 1 - нет}
Result:=0;
end

else if Code<0 {если Code<0, то нужно вызвать следующую ловушку}
then Result := CallNextHookEx(HookHandle,Code, wParam, lParam);
end;

{при выгрузке DLL надо снять ловушку}
procedure LocalExitProc; far;
begin
if HookHandle<>0
then begin
UnhookWindowsHookEx(HookHandle);
ExitProc := SaveExitProc;
end;
end;

exports Key_Hook;

{инициализация DLL при загрузке ее в память}
begin
{устанавливаем ловушку}
HookHandle := SetWindowsHookEx(wh_Keyboard, @Key_Hook,
hInstance, 0);
if HookHandle = 0
then MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok)
else begin
SaveExitProc := ExitProc;
ExitProc := @LocalExitProc;
end;
end.

Unit1.dfm

object Form1: TForm1
Left = 200
Top = 104
Width = 544
Height = 375
Caption = 'XXX'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 128
Top = 68
Width = 32
Height = 13
Caption = 'Label1'
end
end

Unit1.pas

unit Unit1;

interface

uses

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

{пользовательские сообщения}

const
wm_LeftShow_Event = wm_User + 133;
wm_RightShow_Event = wm_User + 134;
wm_UpShow_Event = wm_User + 135;
wm_DownShow_Event = wm_User + 136;

type
TForm1 = class(TForm)
Label1: TLabel;

procedure FormCreate(Sender: TObject);

private //Обработчики сообщений
procedure WM_LeftMSG (Var M : TMessage);
message wm_LeftShow_Event;

procedure WM_RightMSG (Var M : TMessage);
message wm_RightShow_Event;

procedure WM_UpMSG (Var M : TMessage);
message wm_UpShow_Event;

procedure WM_DownMSG (Var M : TMessage);
message wm_DownShow_Event;
end;

var
Form1: TForm1;
P : Pointer;

implementation

{$R *.DFM}

//Загрузка DLL
function Key_Hook(Code: integer; wParam: word; lParam: Longint) : Longint; stdcall; external 'SendKey' name 'Key_Hook';

procedure TForm1.WM_LefttMSG (Var M : TMessage);
begin
Label1.Caption:='Left';
end;

procedure TForm1.WM_RightMSG (Var M : TMessage);
begin
Label1.Caption:='Right';
end;

procedure TForm1.WM_UptMSG (Var M : TMessage);
begin
Label1.Caption:='Up';
end;

procedure TForm1.WM_DownMSG (Var M : TMessage);
begin
Label1.Caption:='Down';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{если не использовать вызов процедуры из DLL в программе,
то компилятор удалит загрузку DLL из программы}
 P:=@Key_Hook;
end;

end.

[000503]


Имитация нажатия клавиши

Я имею набор кнопок (caption ='0'..'9') и хотел бы имитировать их нажатие во время нажатия пользователем соответствующей клавиши. То есть, когда пользователь нажимает клавишу '1', кнопка с таким заголовком также должна быть нажата на экране. Как мне это сделать без нового компонента Tbutton?

Нет проблем:

Вероятно вы захотите использовать 10 элементов управления TSpeedButton или их массив, поскольку этот тип кнопок имеет свойство "Down". Для начала установите у свойства "KeyPreview" вашей формы значение "True". Затем создайте обработчик события "OnKeyDown" примерно такого вида...

case Key of
VK_NUMPAD0: btn0.Down := True;
VK_NUMPAD1: btn1.Down := True;
VK_NUMPAD2: btn2.Down := True;
VK_NUMPAD3: btn3.Down := True;
VK_NUMPAD4: btn4.Down := True;
VK_NUMPAD5: btn5.Down := True;
VK_NUMPAD6: btn6.Down := True;
VK_NUMPAD7: btn7.Down := True;
VK_NUMPAD8: btn8.Down := True;
VK_NUMPAD9: btn9.Down := True;
end;

в этом случае обработчик события "OnKeyUp" будет следующего вида...

case Key of
VK_NUMPAD0: btn0.Down := False;
VK_NUMPAD1: btn1.Down := False;
VK_NUMPAD2: btn2.Down := False;
VK_NUMPAD3: btn3.Down := False;
VK_NUMPAD4: btn4.Down := False;
VK_NUMPAD5: btn5.Down := False;
VK_NUMPAD6: btn6.Down := False;
VK_NUMPAD7: btn7.Down := False;
VK_NUMPAD8: btn8.Down := False;
VK_NUMPAD9: btn9.Down := False;
end;

Поэкспериментируйте со свойствами "AllowAllUp" и "GroupIndex" для получения необходимого эффекта.

Кроме того, массив кнопок TSpeedButtons был бы наиболее изящным решением в данной задаче, поскольку в этом случае вы могли бы использовать константу VK_ constant в качестве индекса, делая обработчики обоих событий длиной всего в одну строчку - Button[VK_x].Down := True {или False}. [000141]


Как? Клавиша ENTER вместо клавиши TAB I

Вот что я нашел на Compuserve, это должно помочь.

Использование клавиши "Enter" подобно клавише "Tab" в элементах управления Delphi

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

Хитрость заключается в переписывании событий Keypress и KeyDown для обработки нажатий любых клавиш. В предоставленном примере я использовал клавишу "Enter" для перемещения к следующему элементу управления (подобно клавише "Tab") и клавиши Up и Down для перемещения к предшествующему и следующему элементу соответственно.

Edit и EBEdit используют клавиши как было сказано выше, но Combobox и Listbox используют Shift-Up и Shift-Down для того, чтобы не создавать помехи существующему функциональному назначению.

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

Метод использует для перемещения на следующий/предыдущий элемент управления вызов Windows API функции SendMessage, которая посылает сообщение WM_NEXTDLGCTL форме, для которой данный элемент является дочерним. Для получения дескриптора родительской формы Delphi осуществляет вызов функции GetParentForm.

Данный код открыт для расширения функциональности, например, на реакцию события при нажатии почти любой клавиши, и я думаю, что использование данного метода является лучшим решением, чем организация перехвата клавиш в событиях формы OnKey (используя keypreview:=true).

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

{
Код, дающий функциональность клавиши "Tab" клавише "Enter", позволяющий
при нажатии на последнюю переместиться к следующему элементу управления.
Так как событие KeyPress переделано незначительно, данный код стабильно
работает и с компонентом TDBedit, полезным для ввода данных в приложении.
Я думаю, что использование данного кода является лучшим решением, чем
организация перехвата клавиш в событиях формы OnKey (keypreview:=true).

Код абсолютно свободен для использования и распространения.

Simon Callcott CIS: 100574, 1034
}

unit Entedit;

interface

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

type
TEnterEdit = class(TEdit)
private

protected

procedure KeyPress(var Key: Char); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;

public

published

end;

procedure Register;

implementation

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

procedure TEnterEdit.KeyPress(var Key: Char);
var
MYForm: TForm;
begin

if Key = #13 then
begin
MYForm := GetParentForm( Self );
if not (MYForm = nil ) then
SendMessage(MYForm.Handle, WM_NEXTDLGCTL, 0, 0);
Key := #0;
end;

if Key <> #0 then inherited KeyPress(Key);

end;

procedure TEnterEdit.KeyDown(var Key: Word; Shift: TShiftState);
var
MYForm: TForm;
CtlDir: Word;
begin

if (Key = VK_UP) or (Key = VK_DOWN) then
begin
MYForm := GetParentForm( Self );
if Key = VK_UP then CtlDir := 1
else CtlDir :=0;
if not (MYForm = nil ) then
SendMessage(MYForm.Handle, WM_NEXTDLGCTL, CtlDir, 0);
end
else inherited KeyDown(Key, Shift);

end;

end.

Решение 2

В. "Есть ли какое-нибудь решение, чтобы использовать клавишу Enter вместа Tab или мыши?"

О. Используйте этот код для обработчика события OnKeyPress компонента Edit:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If Key = #13 Then
Begin
SelectNext(Sender as tWinControl, True, True );
Key := #0;
end;
end;

Это заставляет клавишу Enter вести себя подобно клавише Tab. Теперь произведите выбор всех элементов управления на форме (кроме кнопок), для которых вы хотели бы применить данное поведение, и назначьте им в Инспекторе Объектов для события OnKeyPress уже созданный нами обработчик EditKeyPress. Теперь каждый компонент, выбранный вами, будет обрабатывать клавишу Enter подобно клавише Tab. Если вы хотите передать функциональность на другой родительский уровень (по сравнению с элементами управления), сбросьте у всех компонентов событие OnKeyPress (просто сотрите название обработчика) и назначьте _формам_ для события OnKeyPress обработчик EditKeyPress. Затем измените Sender на ActiveControl и присвойте свойству форм KeyPreview значение True:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If Key = #13 Then
begin
SelectNext(ActiveControl as tWinControl, True, True );
Key := #0;
end;
end;

Это заставит клавишу Enter вести себя подобно клавише Tab для всех (возможных) элементов управления. [000142]


Как? Клавиша ENTER вместо клавиши TAB II

Установите свойство KeyPreview формы в True и используйте следующий обработчик события OnKeyPress.

procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then begin
Key := #0;
PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
end;
end;
[000427]


Caps Lock (и другие подобные клавиши)

Как мне включить Caps Lock? (Естественно, программным путем в Delphi) ...я уж и пробовал, и спрашивал...

попробуй это...

procedure TMyForm.Button1Click(Sender: TObject);
Var
KeyState  :  TKeyboardState;
begin
GetKeyboardState(KeyState);
if (KeyState[VK_NUMLOCK] = 0) then
KeyState[VK_NUMLOCK] := 1
else
KeyState[VK_NUMLOCK] := 0;
SetKeyboardState(KeyState);
end;

Для Caps Lock замените VK_NUMLOCK на VK_CAPITAL. [000144]


Недоступность Ctrl-Alt-Del I

Вопрос:

Программа должна быть классной и небольшой, к тому же она должна загружаться прежде, чем пользователь сможет нажать CTRL-ALT-DEL.

Мое решение:

С помощью Delphi скомпилируйте единственный вызов WIN32API в небольшой .exe файле.

Программа:

program small;

{автор Richard Leigh, Deakin Univesity 1997}

uses
WinProcs;

{$R *.RES}

var
Dummy : integer;

begin
Dummy := 0;
{Отключаем ALT-TAB}
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
{Отключаем CTRL-ALT-DEL}
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
end.

Это главный модуль - без форм и после компиляции ма-а-а-а-ленький такой... [000146]


Недоступность Ctrl-Alt-Del II

Пришло от читателя письмо:

Решил тут вам послать кое какое решение проблемки ctr+alt+del

Function RegisterServiceProcess(dwProcessID, dwType : DWord): DWord;
stdcall external 'Kernel32.dll' name 'RegisterServiceProcess'; //
вызываю kernel32, кричу ей RegisterServiceProcess с каким то
параметрам 1- скрыть , 0 - показать
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessId(), 1);
end;
end.

таки образом пользователь нажав ctr+alt+del не видет прогу в списке.

Fred Dzjuba From DHPon [000774]


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

vk_LButton   = $01;
vk_RButton   = $02;
vk_Cancel    = $03;
vk_MButton   = $04;   { генерятся только системой вместе с L & RBUTTON }
vk_Back      = $08;
vk_Tab       = $09;
vk_Clear     = $0C;
vk_Return    = $0D;
vk_Shift     = $10;
vk_Control   = $11;
vk_Menu      = $12;
vk_Pause     = $13;
vk_Capital   = $14;
vk_Escape    = $1B;
vk_Space     = $20;
vk_Prior     = $21;
vk_Next      = $22;

vk_End       = $23;
vk_Home      = $24;
vk_Left      = $25;
vk_Up        = $26;
vk_Right     = $27;
vk_Down      = $28;
vk_Select    = $29;
vk_Print     = $2A;
vk_Execute   = $2B;
vk_SnapShot  = $2C;
{ vk_Copy      = $2C не используется клавиатурой }
vk_Insert    = $2D;
vk_Delete    = $2E;
vk_Help      = $2F;
{ vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }
{ vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }
vk_NumPad0   = $60;
vk_NumPad1   = $61;
vk_NumPad2   = $62;
vk_NumPad3   = $63;
vk_NumPad4   = $64;
vk_NumPad5   = $65;
vk_NumPad6   = $66;
vk_NumPad7   = $67;
vk_NumPad8   = $68;
vk_NumPad9   = $69;
vk_Multiply  = $6A;
vk_Add       = $6B;
vk_Separator = $6C;
vk_Subtract  = $6D;
vk_Decimal   = $6E;
vk_Divide    = $6F;
vk_F1        = $70;
vk_F2        = $71;
vk_F3        = $72;
vk_F4        = $73;
vk_F5        = $74;

vk_F6        = $75;
vk_F7        = $76;
vk_F8        = $77;
vk_F9        = $78;
vk_F10       = $79;
vk_F11       = $7A;
vk_F12       = $7B;
vk_F13       = $7C;
vk_F14       = $7D;
vk_F15       = $7E;
vk_F16       = $7F;
vk_F17       = $80;
vk_F18       = $81;
vk_F19       = $82;
vk_F20       = $83;
vk_F21       = $84;
vk_F22       = $85;
vk_F23       = $86;
vk_F24       = $87;
vk_NumLock   = $90;
vk_Scroll    = $91;

{ Данные коды взяты из файлов помощи Ллойда (Lloyd) }

[000255]


Посылка кода клавиши/Текста в окно...

Надеюсь это поможет:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
AppInst: THandle;
AppWind: THandle;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses ShellAPI;

procedure SendShift(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $10;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendCtrl(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $11;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendKey(H: Hwnd; Key: char);
var vKey, ScanCode, wParam: Word;
lParam, ConvKey: longint;
Shift, Ctrl: boolean;
begin
ConvKey:= OemKeyScan(ord(Key));
Shift:= (ConvKey and $00020000) <> 0;
Ctrl:= (ConvKey and $00040000) <> 0;
ScanCode:= ConvKey and $000000FF or $FF00;
vKey:= ord(Key);
wParam:= vKey;
lParam:= longint(ScanCode) shl 16 or 1;
if Shift then SendShift(H, true);
if Ctrl then SendCtrl(H, true);
SendMessage(H, WM_KEYDOWN, vKey, lParam);
SendMessage(H, WM_CHAR, vKey, lParam);
lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYUP, vKey, lParam);
if Shift then SendShift(H, false);
if Ctrl then SendCtrl(H, false);
end;

function EnumFunc(Handle: HWnd; TF: TForm1): Bool; Far;
begin
TF.AppWind:= 0;
if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then
TF.AppWind:= Handle;
result:= (TF.AppWind = 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var Text: Array[0..255] of char;
begin
AppInst:= ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL);
EnumWindows(@EnumFunc, longint(self));
AppWind:= GetWindow(AppWind, GW_CHILD);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SendKey(AppWind, 'T');
SendKey(AppWind, 'e');
SendKey(AppWind, 's');
SendKey(AppWind, 't');
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if AppWind <> 0 then SendKey(AppWind, Key);
end;

end.

[000287]


Одной строкой

Хитрость KeyPreview

В обработчик события FormCreate вставьте следующую строчку кода:

KeyPreview:=TRUE;

Это позволит всем событиям, связанным с нажатием клавиш, в первую очередь передаваться форме, чьи обработчики могут выполнить какое-то заранее заданное действие или "подавить" клавиши. Только после этого они передаются выбранному элементу управления. Чтобы полностью "подавить" клавишу, используйте событие OnKeyPress, где код нажатой клавиши имеет тип Char, и для того, чтобы "подавить" его, просто напишите key:=#0. [000348]


Одной строкой

Индикация статуса клавиш I

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

VAR KS : TKeyboardState;
...
GetKeyboardState(KS);
IF Odd(KS[VK_NUMLOCK]) THEN {caps lock нажат}
... VK_VK_CAPITAL
... VK_SCROLL
... VK_INSERT
[000404]


Delphi 1

Индикация статуса клавиш II

Может мне кто-нибудь сказать, где найти код, который помог бы мне связать текст строки состояния с состоянием клавиш caps lock, num lock и др.?

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

TIdleEvent - процедурный тип, имеющий логический параметр Done со значением по умолчанию True. Когда Done равен True, после обработки события OnIdle вызывается функция Windows API WaitMessage. WaitMessage передает управление другим приложениям до тех пор, пока в очереди сообщений вашего приложения не появится новое сообщение. Если Done равно False, WaitMessage не вызывается.

Итак, как мы можем решить нашу задачу в свете вышесказанного:

Добавьте 4 компонента Checkbox к вашему компоненту Statusbar и сделайте следующее объявление в секции Private вашей формы:

procedure AppOnIdle(Sender: TObject; var Done: Boolean);

Добавьте в секции реализации:

procedure TForm1.AppOnIdle(Sender: TObject; var Done: Boolean);
begin
CheckBox1.Checked := Odd(GetKeyState(VK_CAPITAL));
CheckBox2.Checked := Odd(GetKeyState(VK_SHIFT));
CheckBox3.Checked := Odd(GetKeyState(VK_NUMLOCK));
CheckBox4.Checked := Odd(GetKeyState(VK_SCROLL));
Done := False;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := AppOnIdle;
end;

[000617]


Одной строкой

Прерывание клавиши ENTER

Лучший путь решения проблемы - заставить форму возвратить код другой клавиши, в противном случае система найдет на форме кнопку "по умолчанию" и "нажмет" ее. Далее поместите необходимый для обработки клавиши Enter код в обработчик события кнопок OnClick. Основное вы уже сделали, осталось только запустить программу, проконтролировать ее поведение при нажатии Enter и заставить действовать соответственно обстоятельствам. [000434]


Delphi 1

Использование клавиш для управления компонентами

Так, если у меня есть своего рода кнопка (check, radio, speed и т.п.), то почему я не могу с помощью клавиш курсора управлять ею?

После некоторых экспериметов я создал метод, который привожу ниже, способный перехватывать в форме все нажатые клавиши позиционирования и управлять ими выбранным в настоящий момент элементом управления. Имейте в виду, что элементы управления (кроме компонентов Label) должны иметь возможность "выбираться". Для возможности выбрать GroupBox или другой компонент, удедитесь, что их свойство TabStop установлено в True. Вы можете переместить управление на GroupBox, но, так как он не выделяется целиком, узнать, что он действительно имеет управление, достаточно непросто. Если вам не нужно передавать управление в контейнерные элементы (нижеследующий код исходит из этого предположения), то вы можете управлять элементами, просто перемещая управление в сам GroupBox.

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

Надеюсь, что вам помог.

Robert Wittig

{==================================================================}

procedure TForm1.FormActivate(Sender: TObject);
begin
{ Делаем ссылку на нового обработчика сообщений }
Application.OnMessage := ProcessFormMessages;
end;

procedure tForm1.ProcessFormMessages ( var Msg : tMsg; var Handled : Boolean );
Var
Increment  : Byte;
TheControl : tWinControl;
begin
{ проверка наличия системного сообщения KeyDown }
Case Msg.Message Of
WM_KEYDOWN : If Msg.wParam In [VK_UP,VK_DOWN,VK_LEFT,VK_RIGHT] Then
Begin
{ изменяем величину приращения взависимости
от состояния клавиши Shift }
If GetKeyState ( VK_SHIFT ) And $80 = 0 Then
Increment := 8
Else
Increment := 1;

{ Этот код перемещает управление на родительский
GroupBox, если один из его контейнерных элементов
получает фокус. Если вам необходимо управлять
элементами внутри контейнера, удалите блок IF и
измените в блоке CASE TheControl на ActiveControl }
If ( ActiveControl.Parent Is tGroupBox ) Then
TheControl := ActiveControl.Parent
Else
TheControl := ActiveControl;

Case Msg.wParam Of
VK_UP    : TheControl.Top  := TheControl.Top - Increment;
VK_DOWN  : TheControl.Top  := TheControl.Top + Increment;
VK_LEFT  : TheControl.Left := TheControl.Left - Increment;
VK_RIGHT : TheControl.Left := TheControl.Left + Increment;
End;

{ сообщаем о том, что сообщение обработано }
Handled := True;
End;
End;
end;
[000442]


Delphi 1

Перехват курсорных клавиш I

Вы должны перехватывать и обрабатывать сообщение WM_GETDLGCODE. Объявите обработчик сообщения в вашем компоненте (в секции protected будет в самый раз)

procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE;

и реализуйте его:

procedure TMyControl.WMGetDlgCode(var Msg : TMessage);
begin
Msg.Result := DLGC_WANTARROWS;
end;

Cheers, Julian (TeamB & TurboPower Software) [000476]


Delphi 1

Перехват курсорных клавиш II

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

Создайте HandleMessages как метод формы и затем назначьте его Application.HandleMessages.

Procedure tForm1.HandleMessages ( Var Msg : tMsg; Var Handled : Boolean );
Begin
If ( Msg.Message = WM_KeyDown ) And
( Msg.wParam In [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT] ) Then
Begin
Case Msg.wParam Of
VK_UP    : ShowMessage ( 'Нажата стрелка вверх' );
VK_DOWN  : ShowMessage ( 'Нажата стрелка вниз' );
VK_LEFT  : ShowMessage ( 'Нажата стрелка влево' );
VK_RIGHT : ShowMessage ( 'Нажата стрелка вправо' );
End;
Handled := True;
End;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := HandleMessages;
end;

Надеюсь, что помог вам,
Robert Wittig [000669]


Чтение и установка клавиши NumLock

VAR KS : TKeyboardState;
...
GetKeyboardState(KS);
IF Odd(KS[VK_NUMLOCK]) THEN {NumLock включен}

KS[VK_NUMLOCK] := KS[VK_NUMLOCK] XOR 1; {переключение NumLock}
KS[VK_NUMLOCK] := KS[VK_NUMLOCK] OR 1; {включение NumLock}
KS[VK_NUMLOCK] := KS[VK_NUMLOCK] AND (NOT 1); {выключение NumLock}

SetKeyboardState(KS);

Таким же образом:

... VK_CAPITAL
... VK_SCROLL
... VK_INSERT

Nomadic предлагает немного другой способ:

var
abKeyState: array [0..255] of byte;
begin
GetKeyboardState( Addr( abKeyState[ 0 ] ) );
abKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01;
SetKeyboardState( Addr( abKeyState[ 0 ] ) );

Slava Kostin замечает:

Вот что по этому поводу сказано в Help Delphi:

Remarks

Because the SetKeyboardState function alters the input
state of the calling thread and not the global input state
of the system, an application cannot use SetKeyboardState
to set the NUM LOCK, CAPS LOCK, or SCROLL LOCK indicator
lights on the keyboard.
[000560]


Delphi 1

Имитация Tab

SelectNext(screen.ActiveControl, True, True);

Разместите приведенный код в обработчике одного из собитий. SelectNext - защищенный метод TWinControl со следующим прототипом:

procedure SelectNext(CurControl: TWinControl;
GoForward, CheckTabStop: Boolean);

Так как форма также является потомком TWinControl, то она имеет доступ к защищенным методам. [000634]


Обработка нажатий клавиш `вверх-вниз`

Пришло от читателя письмо:

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

procedure TfmAbProps.edNameKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key=vk_down) and
not (ssAlt in Shift)  // здесь обработка для "выпадающих" окошек типа
TRxDBCalcEdit
then begin
Key:=0;
SelectNext(Sender as TWinControl,true,true);
end else
if Key=vk_up then begin
Key:=0;
SelectNext(Sender as TWinControl,false,true);
end;
end;

Для элементов редактирования типа TDbEdit, TRxDBCalcEdit or TDBDateEdit назначим

OnKeyDown:=edNameKeyDown

Сложнее с типами вроде TRxDBLookupCombo. Наш прежний обработчик для них не подходит. Я пытался изменить характер TRxDBLookupCombo - но вовремя опомнился - есть же FormKeyDown;

procedure TfmAbProps.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (ActiveControl is TRxDBLookupCombo) then begin
if Key=vk_down then begin
if not (ssAlt in Shift) and not  // здесь нельзя обработать нажатие при
вызове "выпадающего"
(ActiveControl as TRxDBLookupCombo).IsDropDown then begin // и в случае
уже "выпвшего"
Key:=0;
selectnext(ActiveControl,true,true);
end;
end else
if Key=vk_up then begin
if not (ActiveControl as TRxDBLookupCombo).IsDropDown then begin
Key:=0;
selectnext(ActiveControl,false,true);
end;
end;
end;
end;

С уважением, Галимарзанов Фанис [000796]


Как программно нажать клавишу

Пришло от читателя письмо:

// для WINNT

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

procedure TForm1.SetKey(Key:Integer);
begin
keybd_event(Key,0,KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,0);
keybd_event(Key,0,KEYEVENTF_EXTENDEDKEY,0);
keybd_event(Key,0,KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,0);
end;

Применение

SetKey(VK_SCROLL);
SetKey(VK_CAPITAL);

Den is Com [000819]


Создание собственных горячих клавиш

Как мне перехватывать нажатие созданных мною горячих клавиш?

Во первых установите свойство формы KeyPreview := true;

Затем сделайте что-то типа этого:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then
ShowMessage('Ctrl-A');
end;

[000938]


Прерывание клавиши Tab

Единственное место в программе, где можно перехватить нажатие клавиши tab - в обработчике Application.OnMessages. Пример ниже:

unit Hndltabu;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
private { Private-Deklarationen }
procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
public { Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
const
shiftPressed: boolean = false;
begin
if Msg.Message = WM_KEYDOWN then
if not shiftPressed and (Msg.wParam = VK_SHIFT) then
begin
shiftPressed := true;
Exit;
end
else
begin
if Msg.wParam = VK_TAB then
if ActiveControl = Edit1 then begin
if shiftPressed then
Label1.Caption := 'BACKTAB!'
else
Label1.Caption := 'TAB!';

Handled        := true
end
else
Label1.Caption := '';

shiftPressed := false;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;

end.

- Ralph Friedman [000956]


AT-команды модема

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)
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)

[000179]


S-регистры модема

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)

[000180]


Работа с последовательными портами I

//{$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.

[000238]


Работа с последовательными портами II

Мне необходим код для работы с последовательными портами.

Если вам нужно что-то РЕАЛЬНОЕ, то попробуйте это. Можете только добавить проверку на ошибки.

<<Книги>> Serial Communications: A C++ Developer's Guide by Mark Nelson, M&T Books.

Правда, по большей части это про DOS, а Windows посвящена только одна глава. Проверьте это.

unit Comm;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Forms;
type
TCommEvent = procedure(Sender: TObject; Data: Char) of object;
TCommErrEvent = procedure(Sender: TObject; Error: Integer) of object;
TComm = class(TComponent)
private
Wnd: HWND;
DCB: TDCB;
CommID: Integer;
Buf: Array[0..2048] of char;
NumChars: Integer;
FOnCommErr: TCommErrEvent;
FOnCommRecvd: TCommEvent;
procedure CommWndProc(var Message: TMessage);
public
function Send(data: Char): Boolean;
function Connect: Boolean;
constructor Create(AOwner: TComponent); override;
Destructor destroy; override;
published
Property OnCommErr: TCommErrEvent read FOnCommErr write FOnCommErr;
Property OnCommRecvd: TCommEvent read FOnCommRecvd write FOnCommRecvd;
end;
procedure Register;
implementation

constructor TComm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Wnd := AllocateHwnd(CommWndProc);
end;

procedure TComm.CommWndProc(var Message: TMessage);
var
Error, count: Integer;
Stat: TComStat;
begin
if Message.Msg = WM_COMMNOTIFY then
begin
Message.Result := 0;
GetCommEventMask(CommId, $3fff);
NumChars := ReadComm(CommID, @Buf, 2048);
Error := GetCommError(CommId, Stat);
if Error = 0 then
begin
if Assigned(FOnCommRecvd) then
begin
for count := 0 to NumChars-1 do
FOnCommRecvd(Self, Buf[count]);
end;
end
else
begin
if Assigned(FOnCommErr)  then
begin
FOnCommErr(Self, Error);
end;
end;
end;
end;

function TComm.Send(data: Char): Boolean;
var
Error: Integer;
begin
Error := TransmitCommChar(CommId, data);
if Error < 0 then
Result := False
else
Result := True;
end;

function TComm.Connect: Boolean;
var
Config : array[0..20] of Char;
begin
CommId := OpenComm('COM2', 2048, 2048);
StrCopy(Config, 'com2:96,n,8,1');{Здесь меняем настройки порта}
BuildCommDCB(Config, DCB);
DCB.ID := CommId;
SetCommState(DCB);
EnableCommNotification(CommID, Wnd, 1, -1);
SetCommEventMask(CommId, ev_RXChar);
Result := True;
end;

Destructor TComm.destroy;
begin
CloseComm(CommID);
DeallocateHwnd(Wnd);
Inherited destroy;
end;

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

[000448]


Работа с портами под Win95, обзор и теория

Вступление

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

Проблема

Под MS-DOS приложение управляет всем компьютером. Это развязывало программисту руки. Достижение максимальной скорости работы осуществлялось непосредственным доступом к аппаратным средствам.

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

Другая проблема - вы уже должны были считаться с параллельно запущенными задачами, а не требовать у компьютера в свое распоряжение все ресурсы. Win 3.x осуществляет кооперацию параллельных задач, означая, что каждое приложение должно исходить из концепции совместного существования и не монополизировать ресурсы, а пользоваться услугами специализированного диспетчера. Захват CPU на длительное время здесь не приветствуется.

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

Факт, но тенденция отбивания рук от прямого доступа к железу победила на платформе Win32 (Windows NT и Windows 95). Это операционные системы с истинной многозадачностью. Каждый поток (выполняемый модуль) получает определенный квант процессорного времени. Когда лимит процессорного времени исчерпан, или появляется поток с более высоким приоритетом, система прекращает обслуживать первый поток, даже в случае, если он не завершен. Это переключение между потоками может произойти между двумя ассемблерными инструкциями, нет никакой гарантии, что поток сможет завершить определенное количество инструкций, прежде чем у него отнимут процессорное время, к тому же неизвестно как долго ждать следующей порции процессорного времени.

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

mov dx, AddressPort
mov al, Address
out dx, al
jmp Wait
Wait:
mov dx, DataPort
in al, dx

Состояние всех регистров при переключении потоков сохраняется, состояние I/O портов (последовательные порты, порты ввода/вывода) - нет. Так, велика вероятность что другие приложения производят другие операции с I/O портом, в то время как вы "застряли" между инструкциями 'out' и 'in'.

Документированный путь

Для решения этой проблемы мы должны как-то сообщить всем другим приложениям, что "К настоящему времени MyProg использует порт 546, и всем оставаться на своих местах до моего особого распоряжения." В этом случае подешел бы мьютекс. К сожалению, для использования созданного мьютекса все приложения должны знать его имя. Но даже если бы это было возможно, вы легко можете наткнуться на другие заковыристые проблемы. Рассмотрим два приложения - App1 и App2. Оба пытаются выполнить вышеприведенный код. К несчастью, они созданы разными программистами с разным взглядом на технологию доступа, поэтому App1 сначала требует AddressPortMutex, в то время как App2 требует DataPortMutex. И, по печальному совпадению, когда App1 получает AddressPortMutex, система переключается на App2, которое захватывает DataPortMutex и получается праздник смертельного объятия. App2 не может получить адрес порта, т.к. его захватило App1. App1 не может получить данные порта, т.к. это захватило App2. И все чего-то ждут...

Правильное решение - создание драйвера устройства, которой единолично владеет портами/памятью. Доступ к аппаратным средствам осуществляется посредством API. Вот типичный вызов:

GetIOPortData(AddressPort, DataPort : word) : Byte;

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

Создание драйвера устройства дело нелегкое. Он должен быть создать с помощью ассемблера или C и невероятно труден в отладке. Более того, из-за соображений безопасности драйверы устройств для Windows 95 (VxD) не совместимы с драйверами для Windows NT (VDD, virtual device driver - виртуальный драйвер устройства). Говорят, что в будущих версиях они будут совместимы, и Windows NT 6.0 и Windows 2000 будут использовать одни и те же драйвера, но пока разработчики вынуждены заниматься созданием двух различных версий.

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

Microsoft Windows 95 Device Driver Kit

Microsoft Windows NT Device Driver Kit

Microsoft Press "Systems Programming for Windows 95" автора Walter Oney

Также вы можете ознакомиться с библиотекой Vireo VtoolsD на предмет написания VxD в C, расположенной по адресу http://www.vireo.com/.

Недокументированный путь

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

К счастью, в Windows 95 заложена совместимость с Windows 3.x. Это означает, что директивное использование I/O портов также возможно, поскольку до сих пор находятся в эксплуатации множество 16-битных программ, которые просто не могут работать по другому. Просто в этом случае при кодировании вам придется спуститься до уровня ассемблера. Автор следующего кода Arthur Hoornweg (hoornweg@hannover.sgh-net.de):

function getport(p:word):byte; stdcall;
begin
asm
push edx
push eax
mov  dx,p
in   al,dx
mov  @result,al
pop  eax
pop  edx
end;
end;

Procedure Setport(p:word;b:byte);Stdcall;
begin
asm
push edx
push eax

mov dx,p
mov al,b
out dx,al

pop  eax
pop  edx
end;
end;

François Piette также предлагает свое решение прямого доступа к портам I/O на страничке http://rtfm.netline.be/fpiette/portiofr.htm

Как насчет NT?

Но все вышесказанное под Windows NT работать не будет. NT более "прочная" операционная система, поэтому если она позволит в любое время кому попало обращаться к любым аппаратным средствам, она не была бы такой устойчивой. Кроме того, NT является кроссплатформенной системой, поэтому доступ к I/O портам может кардинально различаться при работе на различных процессорах.

Но тем не менее даже под NT можно добраться непосредственно до I/O портов, правда только на x86 процессорах. Это не является документированной особенностью, и, вероятно, исчезнет в будущих версиях этой операционной системы.

Я не обладаю достаточно полной информацией по этому вопросу, но интересующая нас статья D. Roberts в майском номере журнала Dr. Dobb's Journal за 1996 год так и называется "Direct Port I/O and Windows NT." К сожалению, я так и не нашел времени проверить приведенный там код. Статью и посвященный ей флейм вы можете почитать по адресу http://www.ddj.com.

Также рекомендую ознакомиться с опубликованной в Windows Developer Journal статьей "Port I/O under Windows." Опубликована Karen Hazzah в июне 1996 года. Статью и посвященный ей флейм вы можете найти по адресу http://www.wdj.com.

Ресурсы

(Примечание, я не очень много знаю об этих ресурсах, проверьте их пожалуйста сами.)

Существуют новостные группы, посвященные написанию VxD и VDD:

comp.os.ms-windows.programmer.nt.kernel-mode (VDD)

comp.os.ms-windows.programmer.vxd (VxD)

Dejanews (http://www.dejanews.com) выдает достаточно много результатов, если для поиска задать фразу 'device driver direct I/O access 95'.

Компания BlueWater Systems разработала OCX, осуществляющее прямой доступ к I/O портам, памяти и прерываниям, работающее под всеми Win32 платформами. Они также, кажется, предлагают изготовление драйверов устройств под заказ. Посмотрите их сервер по адресу http://www.bluewatersystems.com/.

Я сляшал, что какая-то другая компания также рекламировала свои услуги в области разработчики VxD, но я не нашел их адреса.

[000239]


Delphi 2

Доступ к аппаратным портам из DELPHI 2

function InPort(PortAddr: word): byte;
{$IFDEF VER90}
assembler; stdcall;
asm
mov dx,PortAddr
in al,dx
end;
{$ELSE}
begin
Result := Port[PortAddr];
end;
{$ENDIF}

procedure OutPort(PortAddr: word; Databyte: byte);
{$IFDEF VER90}
assembler; stdcall;
asm
mov al,Databyte
mov dx,PortAddr
out dx,al
end;
{$ELSE}
begin
Port[PortAddr] := DataByte;
end;
{$ENDIF}

[000241]


Delphi 1

Чтение/Запись в IO-порт

A := Port[20];   {чтение байта из порта 20}
Port[20] := A;   {запись байта в порт 20}
B := PortW[20];  {чтение слова из порта 20-21}
PortW[20] := B;  {запись слова в порт 20-21}

[000597]


Добавление события 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;

Дополнение

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

  1. MouseEnter - когда событие мыши входит в пределы визуального компонента;
  2. MouseLeave - когда событие мыши оставляет его пределы.
Известно, что все Delphi объявляет эти сообщения в виде:
  1. Cm_MouseEnter;
  2. 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.

Best regards,
Briculski, bserge@airport.md [000181]


Использование анимированных курсоров

Привет.

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

Вот пример:

(mycursor.ani - файл, содержащий анимированный курсор. Вы можете создать его с помощью программы Microsoft aniedit.exe)

const crMyCursor = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
// Загружаем курсор. Единственный способ для этого
Screen.Cursors[crMyCursor] :=
LoadCursorFromFile('c:\mystuff\mycursor.ani');
// Используем курсор на форме
Cursor := crMyCursor;
end;

Я надеюсь, что помог вам этой информацией.

[000182]


Создание мышиного перехватчика

library Hookdemo;

uses

Beeper in '\DELDEMOS\HOOKDEMO\BEEPER.PAS';

exports
SetHook index 1,
UnHookHook index 2,
HookProc index 3;

begin
HookedAlready:=False;
end.

, где beeper.pas содержит следующий код:

unit Beeper;

interface

uses Wintypes,Winprocs,Messages;

function SetHook:Boolean;export;
function UnHookHook:Boolean;export;
function HookProc(Code:integer; wParam: Word; lParam: Longint): Longint;export;

var HookedAlready:Boolean;

implementation

var
ourHook:HHook;

function SetHook:Boolean;
begin
if HookedAlready then exit;
ourHook:=SetWindowsHookEx(WH_MOUSE,HookProc,HInstance,0);
HookedAlready:=True;
end;

function UnHookHook:Boolean;
begin
UnHookWindowsHookEx(ourHook);
HookedAlready:=False;
end;

function HookProc(Code:integer; wParam: Word; lParam: Longint): Longint;
begin
if (wParam=WM_LBUTTONDOWN) then MessageBeep(0);
result:=CallNextHookEx(ourHook,Code,wParam,lParam);
end;

end.

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

[000183]


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

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

Вы должны обрабатывать сообщения CM_MOUSEENTER и CM_MOUSELEAVE примерно таким образом:

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 при прорисовке области компонента или использовать иное решение. [000185]


Покидание мыши области компонента

Кто-нибудь знает как мне определить момент покидания мыши области компонента?

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if (X = 0) or (X = Panel1.Width) or (Y = 0) or (Y = Panel1.Width) then
Screen.Cursor := crHSplit
else
Screen.Cursor := crDefault;
end;

Техника, которую я применяю, подразумевает использование события OnMouseMove ВСЕМИ моими компонентами, (включая панель, на которой они расположены). В момент покидания мыши области кнопки возникает событие Panel.OnMouseMove у панели, на которой она расположена. Это может показаться непрактичным, но для решения моей задачи вполне подходит. BTW, было бы неплохо соорудить компонент, который имел бы опубликованными все события, начинающиемя с префикса CM_xxx, в этом случае ни одна из манипуляций мыши в области компонента не осталась бы незамеченной. Для справки привожу порядок возникновения всех возможных событий мыши: попадание мыши в область клиента OnEnter, MouseMove - перемещение мыши, следом идет щелчок OnClick, затем двойной щелчок и, наконец, уход мыши с области клиента (OnExit). [000186]


Delphi 1

Определение и использование курсора

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

implementation

{$R MyApp01.Res}

Вы не можете назначить курсор свойству компонента Cursor или DragCursor из .RES-файла напрямую, необходимо выполнить несколько промежуточных шагов. В каждом проекте Delphi определяет глобальный объект с именем Screen (тип TScreen), который, между прочим, определяет массив курсоров, называемый, как ни странно, Cursors. Когда вы щелкаете на свойстве Cursor/DragCursor в Инспекторе объектов, выпадающий список и есть список элементов указанного массива.

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

Для начала определите константу, допустим так:

Const
MyCursor = 1;

Далее необходимо загрузить курсор. Сделать это можно в обработчике события формы OnCreate:

Screen.Cursors[MyCursor] := LoadCursor(HInstance, 'MYCURSOR');

Затем просто установите в свойстве DragCursor любого элемента управления:

MyListbox.DragCursor := MyCursor;

Примечание: имя вашего курсора всегда должно писаться в ВЕРХНЕМ регистре, как при вызове LoadCursor, так и в его названии в .RES-файле. [000473]


Delphi 1

Управление MouseOver через Hint

Cуществует ли какой-либо способ отловить момент попадания курсора в область компонента? А его уход оттуда? Мне необходимо убедиться в видимости элемента управления под курсором мыши и совершить над ним некоторые действия.

Вы можете приспособить для этих целей метод OnHint класса TApplication. Данный метод вызывается при перемещении мыши над компонентом и, обычно в ответ на это, становится видимой всплывающая подсказка, а заголовок компонента присваивается величине Application.Hint. Тем не менее вы НЕ должны пользоваться этим решением. Зато при наступлении события вы можете проверять величину Hint для определения того, над каким компонентом в данный момент находится курсор мыши. Стоящая попытка, во всяком случае!

Вот некоторые детали для усвоения идеи. Я расположил на форме компоненты button, edit и label, установил их свойство Hint соответственно в 'Button', 'Edit' и 'Label', и создал несколько их дубликатов. Далее я добавил компонент TRadioGroup, содержащий три элемента, Button, Edit и Label. И, наконец, я реализовал метод приложения OnHint следующим образом:

procedure TForm1.AppOnHint(Sender: TObject);
begin
WITH Application DO
IF Hint='Button' THEN
RadioGroup1.ItemIndex := 0
ELSE IF Hint='Edit' THEN
RadioGroup1.ItemIndex := 1
ELSE IF Hint='Label' THEN
RadioGroup1.ItemIndex := 2
ELSE RadioGroup1.ItemIndex := -1;
end;

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

- Neil

Событие OnShowHint в данном контексте, по-моему мнению, должно подойти больше, поскольку HintControl уже доступен в записи THintInfo объекта TShowHintEvent. К тому же, с помощью него гораздо удобнее производить проверку типа и др.... и вы все еще можете при желании использовать всплывающие подсказки по назначению.

-= Gary =- (TurboPower Software)

О да! Эта идея еще интереснее. И как я ее пропустил! Хотя, с другой стороны, получение информации теперь будет связано с задержкой, обозначенной величиной HintPause. Конечно можно установить HintPause в 0... Главное, что это работает. Классная идея!

- Neil [000588]


Просмотр буфера обмена I

Пример на основе простого модуля-класса, осуществляющего просмотр буфера обмена.

unit ClipboardViewer;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FNextViewerHandle : THandle;
procedure WMDrawClipboard (var message : TMessage);
message WM_DRAWCLIPBOARD;
procedure WMChangeCBCHain (var message : TMessage);
message WM_CHANGECBCHAIN;
public
end;
var
Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
// Проверяем работоспособность функции.
// При невозможности просмотра буфера обмена
// функция возвратит значение Nil.
FNextViewerHandle := SetClipboardViewer(Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// Восстанавливаем цепочки.
ChangeClipboardChain(Handle, FNextViewerHandle);
end;

procedure TForm1.WMDrawClipboard (var message : TMessage);
begin
// Вызывается при любом изменении содержимого буфера обмена
message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);
end;

procedure TForm1.WMChangeCBCHain (var message : TMessage);
begin
// Вызывается при любом изменении цепочек буфера обмена.
if message.wParam = FNextViewerHandle then begin
// Удаляем следующую цепочку просмотра. Корректируем внутреннюю переменную.
FNextViewerHandle := message.lParam;
// Возвращаем 0 чтобы указать, что сообщение было обработано
message.Result := 0;
end else begin
// Передаем сообщение следующему окну в цепочке.
message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,
message.wParam, message.lParam);
end;
end;

end.
[000039]


Просмотр буфера обмена II

Просмотр буфера обмена в Delphi совсем не сложен. Вот участок кода программы, вешающий цепочки в буфере обмена и просто отображающий его текст. Расположите компонент Memo на главной форме нового проекта, присвойстве свойству Align значение alClient, добавьте необходимые private-поля и методы и создайте их реализацию следующим образом:

...
private
{ Private declarations }
PrevHwnd : Hwnd;
procedure WMChangeCBChain(VAR Msg: TWMChangeCBChain);
message WM_CHANGECBCHAIN;
procedure WMDrawClipboard(VAR Msg: TWMDrawClipboard);
message WM_DRAWCLIPBOARD;
...
procedure TForm1.WMChangeCBChain(VAR Msg: TWMChangeCBChain);
begin
IF PrevHWnd = Msg.Remove THEN
PrevHWnd := Msg.Next;
IF Msg.Remove <> Handle THEN
SendMessage(PrevHWnd, WM_CHANGECBCHAIN, Msg.Remove, Msg.Next);
end;

procedure TForm1.WMDrawClipboard(VAR Msg: TWMDrawClipboard);
VAR
P : PChar;
H : THandle;
begin
SendMessage(PrevHWnd, WM_DRAWCLIPBOARD, 0, 0);
IF Clipboard.HasFormat(CF_TEXT) THEN
BEGIN
H := Clipboard.GetAsHandle(CF_TEXT);
Len := GlobalSize(H)+1;
P := GlobalLock(H);
Memo1.SetTextBuf(P);
GlobalUnlock(H);
END;
Msg.Result := 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
PrevHwnd := SetClipboardViewer(Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
ChangeClipboardChain(Handle, PrevHwnd);
end;

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

- Neil [000523]


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

Две вспомогательных процедуры:

procedure CopyButtonClick(Sender: TObject);
begin
If ActiveControl is TMemo then TMemo(ActiveControl).CopyToClipboard;
If ActiveControl is TDBMemo then TDBMemo(ActiveControl).CopyToClipboard;
If ActiveControl is TEdit then TEdit(ActiveControl).CopyToClipboard;
If ActiveControl is TDBedit then TDBedit(ActiveControl).CopyToClipboard;
end;

procedure PasteButtonClick(Sender: TObject);
begin
If ActiveControl is TMemo then TMemo(ActiveControl).PasteFromClipboard;
If ActiveControl is TDBMemo then TDBMemo(ActiveControl).PasteFromClipboard;
If ActiveControl is TEdit then TEdit(ActiveControl).PasteFromClipboard;
If ActiveControl is TDBedit then TDBedit(ActiveControl).PasteFromClipboard;
end;
[000040]


Форма как графический объект

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

uses clipbrd;

procedure TShowVRML.Kopieren1Click(Sender: TObject);
var bitmap:tbitmap;
begin
bitmap:=tbitmap.create;
bitmap.width:=clientwidth;
bitmap.height:=clientheight;
try
with bitmap.Canvas do
CopyRect (clientrect,canvas,clientrect);
clipboard.assign(bitmap);
finally
bitmap.free;
end;
end;
[000041]


Поддержка Cut Copy Paste I

Автор: "Shejchenko Andrij" <andrij@dep01.niiit.kiev.ua>

Я использую следующую процедуру. Вызывайте ее при нажатии на соответвующих пунктах меню. Это будет работать со всеми "редактируемыми" элементами управления. Но для деревьев вы должны использовать специальные сообщения редактирования.

procedure TMainForm.EditUndo(Sender: TObject);
var Mes:TWMUndo;
begin
Mes.Msg:=WM_UNDO;
Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditCut(Sender: TObject);
var Mes:TWMCut;
begin
Mes.Msg:=WM_CUT;
Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditCopy(Sender: TObject);
var Mes:TWMCopy;
begin
Mes.Msg:=WM_COPY;
Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditPaste(Sender: TObject);
var Mes:TWMPaste;
begin
Mes.Msg:=WM_PASTE;
Screen.ActiveControl.Dispatch(Mes);
end;
[000302]


Поддержка Cut Copy Paste II

Свойство формы ActiveControl позволяет вам получить ссылку на активный в данный момент элемент управления. Но не все элементы управления могут работать с буфером обмена. Если вы хотите работать только с компонентами Edit и Memo, то вот самый простой метод:

ActiveControl.Perform( WM_COPY, 0, 0 );

для CopyToClipboard и:

ActiveControl.Perform( WM_PASTE, 0, 0 );

для PasteFromClipboard.

Если элемент управления "не понимает" посланных сообщений, то это никак не скажется на его работе, он просто проигнорирует их.

Другим способом является проверка типа во время выполнения приложения:

If ActiveControl Is TCustomEdit Then
TCustomEdit(ActiveControl).CopyToClipboard;

- Peter Below [000851]


Delphi 1

Cut/Copy/Paste через WinAPI

SendMessage(GetFocus,WM_CUT,0,0);
SendMessage(GetFocus,WM_COPY,0,0);
SendMessage(GetFocus,WM_PASTE,0,0);

Я не проводил тщательного тестирования, но, похоже, это работает со всеми элементами управления - - TEdit, DBGrid и др.

-Peter M. Jagielski [000595]


Delphi 1

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

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

function _hread(FileHandle:word; BufPtr:pointer;
ByteCount:longint):longint; far;
external 'KERNEL' index 349;

Procedure CopyFileToClipboard( Const fname: String );
Var
hmem, hFile : THandle;
size : LongInt;
p : Pointer;
Begin
hFile := FileOpen( fname, fmOpenRead );
try
size := FileSeek( hFile, 0, 2 );
FileSeek( hfile, 0, 0 );
If size > 0 Then Begin
hmem := GlobalAlloc( GHND, size );
If hMem <> 0 Then Begin
p := GlobalLock( hMem );
If p <> Nil Then Begin
_hread( hFile, p, size );
GlobalUnlock( hMem );
Clipboard.SetAsHandle( CF_TEXT, hMem );
End
Else
GlobalFree( hMem );
End;
End;
finally
FileClose( hFile );
end;
End;

procedure TForm1.SpeedButton2Click(Sender: TObject);
Var
fname: String[128];
begin
If OpenDialog1.Execute Then Begin
fname := OpenDialog1.Filename;
CopyFileToClipboard( fname );
End;
end;

- Peter Below [000799]


Delphi 1

функции меню Вырезать/Копировать/Вставить

Есть два шага, положенных в основу работы функций cut/copy/paste. Во-первых, вам нужно знать, какие пункты меню "Редактирование" должны быть в данный момент включены. Во-вторых, вам необходимо работать с тем элементом управления, который в данный момент выбран. Вот возможное решение:

procedure TForm1.Edit1Click(Sender: TObject);
begin
IF ActiveControl IS TCustomEdit THEN
BEGIN
WITH TCustomEdit(ActiveControl) DO
BEGIN
Cut1.Enabled := SelLength > 0;
Copy1.Enabled := SelLength > 0;
Paste1.Enabled := ClipBoard.HasFormat(CF_TEXT);
END;
END
ELSE
BEGIN
Cut1.Enabled := False;
Copy1.Enabled := False;
Paste1.Enabled := False;
END;
end;

procedure TForm1.Cut1Click(Sender: TObject);
begin
IF ActiveControl IS TDBEdit THEN
WITH TDBEdit(ActiveControl).DataSource.DataSet DO Edit;
TCustomEdit(ActiveControl).CutToClipboard;
IF ActiveControl IS TDBEdit THEN
WITH TDBEdit(ActiveControl).DataSource.DataSet DO Post;
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
TCustomEdit(ActiveControl).CopyToClipboard;
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
IF ActiveControl IS TDBEdit THEN
WITH TDBEdit(ActiveControl).DataSource.DataSet DO Edit;
TCustomEdit(ActiveControl).PasteFromClipboard;
IF ActiveControl IS TDBEdit THEN
WITH TDBEdit(ActiveControl).DataSource.DataSet DO Post;
end;

Хорошо? Edit1 - меню редактирования верхнего уровня - если по нему щелкают, то прежде, чем меню "вывалится" вниз, происходит проверка того, принадлежит ли текущий активный элемент управления некоторым типам редактирования. Если это условие выполняется, активизируются пункты меню Вырезать и Копировать, и, если есть текст в буфере обмена, то и пункт Вставить. Если нет, то все три пункта будут недоступны.

Для копирования содержимого элемента редактирования достаточно просто вызвать CopyToClipboard; это не проблема. Для вырезания и вставки вам необходимо *ИЗМЕНИТЬ* содержимое активного элемента редактирования - если это DBEdit, вам необходимо перейти в режим редактирования и после манипуляций с данными буфера обмена запостить измененные данные.

- Neil J. Rubenking [000801]


Delphi 1

Помещение изображения в буфер обмена

var
BMP: TBitmap;hBmp:HBITMAP;
begin
BMP := TBitmap.Create;
BMP.LoadFromFile('имя файла');

hBmp:=BMP.Handle;

Clipboard.Assign(BMP);
{здесь освобождаем объекты}
end;

(Очевидно) Clipboard.Assign требует наличия HBITMAP, и чтобы он создавался не LoadFromFile, но HBITMAP создается при ссылке на BMP.Handle. (Примеры в документации - Clipboard.Assign(aTImage.Picture); у нас уже создан дескриптор окна.)

Надеюсь, это поможет.

- Dave Ullrich


Встроенные форматы буфера обмена

Где бы мне раздобыть список встроенных в win95 форматов буфера обмена и соответствующие им номера?

Вы можете получить эту информацию с помощью следующей процедуры:

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;

- Peter Below [000966]


Панель Управления

Кто-нибудь знает как поместить приложение Delphi в Панель Управления?

Если вы используете Delphi3, добавьте модуль Cpl в файл проекта.

Вот код примера.

library Project1; {Измените "program" на "library"}

uses
Cpl, {используем модуль Cpl}
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

procedure ExecuteApp;
begin
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
end;

{Сallback-функция для экспорта в Панель Управления}
function CPlApplet(hwndCPl: THandle; uMsg: DWORD;
lParam1, lParam2: LongInt):LongInt;stdcall;
var
NewCplInfo:PNewCplInfo;
begin
Result:=0;
case uMsg of
{Инициализация должна возвращать True.}
CPL_INIT:
Result:=1;
{Число апплетов}
CPL_GETCOUNT:
Result:=1;
{Помещаем информацию об этом апплете в Панель управления.}
CPL_NEWINQUIRE:
begin
NewCplInfo:=PNewCplInfo(lParam2);
with NewCplInfo^ do
begin
dwSize:=SizeOf(TNewCplInfo);
dwFlags:=0;
dwHelpContext:=0;
lData:=0;
{Иконка для отображения на Панели Управления.}
hIcon:=LoadIcon(HInstance,'MAINICON');
{Имя апплета}
szName:='Project1';
{Описание этого апплета.}
szInfo:='Это тестовый апплет.';
szHelpFile:='';
end;
end;
{Выполнение апплета.}
CPL_DBLCLK:
ExecuteApp;

else Result:=0;
end;
end;

{Экспортирование функции CplApplet}
exports
CPlApplet;

begin
end.

Для использования апплета измените его расширение с "dll" на "cpl" и поместите в системную директорию.

Апплет будет добавлен к списоку уже существующих (Display, Fonts, Mouse, System и другие). [000290]


Как удалить файлы в корзину (Recycle Bin)?

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;
[000077]


Процедура форматирования

В Shell32.dll спрятана WinAPI функция SHFormatDrive, вызывающая стандартный диалог форматирования сменного накопителя. Я уже встречал этот вопрос в конференции borland.public.delphi.winapi.

{раздел реализации}
..
..
const
SHFMT_ID_DEFAULT        = $FFFF;
// Опции форматирования
SHFMT_OPT_QUICKFORMAT   = $0000;
SHFMT_OPT_FULL          = $0001;
SHFMT_OPT_SYSONLY       = $0002;
// Коды ошибок
SHFMT_ERROR             = $FFFFFFFF;
SHFMT_CANCEL            = $FFFFFFFE;
SHFMT_NOFORMAT          = $FFFFFFFD;

function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word): LongInt;
stdcall; external 'shell32.dll' name 'SHFormatDrive'

procedure TForm1.btnFormatDiskClick(Sender: TObject);
var
retCode: LongInt;
begin
retCode:=       SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
if retCode < 0 then
ShowMessage('Не могу отформатировать накопитель');
end;

end.

Как удалить все файлы из директории?

Попробуй это:

procedure TfrmMain.DelDir(DirName: string);
var
SearchRec: TSearchRec;
GotOne: integer;
begin
GotOne:= FindFirst(DirName + '\*.*', faAnyFile, SearchRec);
while GotOne = 0 do
begin
if ((SearchRec.Attr and faDirectory) = 0) then
DeleteFile(DirName + '\' + SearchRec.Name)
else if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
DelDir(DirName + '\' + SearchRec.Name);
GotOne:= FindNext(SearchRec);
end;
FindClose(SearchRec);
end;

Если впоследствии Вы захотите директорию удалить, попробуйте сделать так:

//--------
DelDir('C:\WASTE');
{-I}
RmDir('C:\WASTE');
{+I}
if IOResult <> 0 then
raise Exception.Create('Ошибка удаления каталога');
//-------

Автор рекурсивного кода David Ullrich. [000079]


Как мне подсчитать занимаемое директорией место?

Попробуйте следующий код (он просматривает скрытые, системные, архивные и нормальные файлы, использует рекурсивный алгоритм для просмотра всех вложенных поддиректорий: достаточно указать стартовый каталог и функция возвратит результат в переменной DirBytes, имейте в виду, что для определения типа (файл или директория) код использует функции FileExists и DirectoryExists вместо просмотра атрибутов файла. Причина этого проста - при просмотре CD-ROM функции FindFirst и FindNext иногда заявляют, что файл является каталогом. В коде я обошел эту ошибку. Возвращаемая размерность - байты.):

var
DirBytes : integer;

function TFileBrowser.DirSize(Dir:string):integer;
var
SearchRec : TSearchRec;
Separator : string;
begin
if Copy(Dir,Length(Dir),1)='\' then
Separator := ''
else
Separator := '\';
if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then begin
if FileExists(Dir+Separator+SearchRec.Name) then begin
DirBytes := DirBytes + SearchRec.Size;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists(Dir+Separator+SearchRec.Name) then begin
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin
DirSize(Dir+Separator+SearchRec.Name);
end;
end;
while FindNext(SearchRec) = 0 do begin
if FileExists(Dir+Separator+SearchRec.Name) then begin
DirBytes := DirBytes + SearchRec.Size;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists(Dir+Separator+SearchRec.Name) then
begin
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin
DirSize(Dir+Separator+SearchRec.Name);
end;
end;
end;
end;
FindClose(SearchRec);
end;
[000081]


Как прочесть атрибут файла "Last Accessed" (последний доступ)?

Если в Проводнике Windows 95 на любом файле нажать правую кнопку мыши и выбрать пункт "Свойства", можно увидеть время последнего доступа к данному файлу.

Как мне это сделать через Delphi/API???

procedure TForm1.Button1Click(Sender: TObject);
var
FileHandle : THandle;
LocalFileTime : TFileTime;
DosFileTime : DWORD;
LastAccessedTime : TDateTime;
FindData : TWin32FindData;
begin
FileHandle := FindFirstFile('AnyFile.FIL', FindData);
if FileHandle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime,
LongRec(DosFileTime).Hi,LongRec(DosFileTime).Lo);
LastAccessedTime := FileDateToDateTime(DosFileTime);
Label1.Caption := DateTimeToStr(LastAccessedTime);
end;
end;
end;
[000085]


Как мне преобразовать "Long File Name.pas" в "longfi~1.pas"?

Попробуйте эти процедуры:

Function GetShortFileName(Const FileName : String) : String;
var
aTmp: array[0..255] of char;
begin
if GetShortPathName(PChar(FileName),aTmp,Sizeof(aTmp)-1)=0 then
Result:= FileName
else
Result:=StrPas(aTmp);
end;

Function GetLongFileName(Const FileName : String) : String;
var
aInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
Result:= String(aInfo.szDisplayName)
else
Result:= FileName;
end;
[000086]


Проблема получения времени создания файла

Попробуйте следующую функцию, которая не требует вызова FindFirst:

function GetFileDate(TheFileName: string): string;
var
FHandle: integer;
begin
FHandle := FileOpen(TheFileName, 0);
result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
FileClose(FHandle);
end;

Одно маленькое предупреждение: время, возвращаемое Win32-функцией, отсчитывается от Гринвича, поэтому вам необходимо привести полученный результат к локальному времени. Чтобы быть уверенным, проверьте документацию. (Я уверен, что FindNextFile делает это правильно). [000087]


Копирование файлов I

У меня есть проблема с копированием файлов. Delphi не хочет компилировать команду LZCopy.

Данный способ очень медленный:

pbBuf := PChar( LocalAlloc(LMEM_FIXED, 1) );

FileSeek(source,0,0);
FileSeek(dest,0,0);
repeat
cbRead := Fileread(source, pbBuf, 1);
FileWrite(dest, pbBuf, cbRead);
until (cbRead = 0);

Решение 1

{  Не забудьте добавить LZExpand в список используемых модулей (USES LZExpand;) }
function CopyFile(SrcF,DestF : string) : boolean;L
var
SFile,
DFile : integer;
Res   : longint;
Msg   : string;

begin
SFile := FileOpen(SrcF,0);        { Открытие ReadOnly = 0, Write=1, Readwrite=2}
DFile := FileCreate(DestF);
Res := LZCopy(SFile,DFile);
FileClose(SFile);
FileClose(DFile);
if Res < 0 then
begin
Msg := 'Неизвестная ошибка';
case Res of
LZERROR_BADINHANDLE   : Msg := 'Неверный дескриптор исходного файла';
LZERROR_BADOUTHANDLE  : Msg := 'Неверный дескриптор файла-приемника';
LZERROR_BADVALUE      : Msg := 'Входной параметр вышел за границы диапазона';
LZERROR_GLOBALLOC     : Msg := 'Недостаточно памяти для требуемого буфера';
LZERROR_GLOBLOCK      : Msg := 'Неверный дескриптор структуры внутренних данных';
LZERROR_READ          : Msg := 'Неверный формат исходного файла';
LZERROR_UNKNOWNALG    : Msg := 'Исходный файл был сжат неизвестным алгоритмом сжатия';
LZERROR_WRITE         : Msg := 'Недостаточно места для выходного файла';
end;
MessageDlg(Msg,mtERROR,[mbOK],0);
result := FALSE
end else
result := TRUE;
end;

Решение 2

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

Решение 3

Самый простой способ копирования файлов:

VAR
sI,dI:Longint;
sD,sS:TFilename;

USES LZExpand;
............
sI := FileOpen(sS,fmShareDenyWrite);
dI := FileCreate(sD);
{ Копирование файла }
CopyLZFile(sI,dI);
{ Закрытие файла }
FileClose(sI);
FileClose(dI);
............

[000088]


Delphi 1

Копирование файлов II

Как мне скопировать файл?

Вот три способа:

{Данный способ использует файловый поток.}
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 ) ;
finally
T.Free;
end;
finally
S.Free;
end;
End;

{Данный способ для чтения/записи использует блоки памяти.}
procedure FileCopy(const FromFile, ToFile: string);
var
FromF, ToF: file;
NumRead, NumWritten: Word;
Buf: array[1..2048] of Char;
begin
AssignFile(FromF, FromFile);
Reset(FromF, 1);          { Размер записи = 1 }
AssignFile(ToF, ToFile);  { Открываем выходной файл }
Rewrite(ToF, 1);          { Размер записи = 1 }
repeat
BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
BlockWrite(ToF, Buf, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
ClloseFile(FromF);
CloseFile(ToF);
end;

{Данный способ использует LZCopy, добавьте в список USES модуль LZExpand.}
procedure CopyFile(FromFileName, ToFileName: string);
var
FromFile, ToFile: File;
begin
AssignFile(FromFile, FromFileName); { Присваиваем FromFile FromFileName }
AssignFile(ToFile, ToFileName);     { Присваиваем ToFile ToFileName }
Reset(FromFile);                    { Открываем файл для чтения }
try
Rewrite(ToFile);                  { Создаем файл для записи }
try
{ копируем файл, если возвращена отрицательная величина }
{ возбуждаем исключение }
if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle) < 0
then
raise EInOutError.Create('Ошибка использования LZCopy')
finally
CloseFile(ToFile);  { Закрываем ToFile }
end;
finally
CloseFile(FromFile);  { Закрываем FromFile }
end;
end;

[000621]


Поиск на винчестере

Я ищу метод или компонент, производящий поиск каких-либо файлов на винчестере, например, (*.exe)...

unit Audit1;
interface
uses windos;

var
dest:string;

procedure dorecurse(dir:string);

implementation
{$R *.DFM}
Procedure Process (dir:string; Searchrec:tsearchrec);
begin
showmessage (Searchrec.name);
case Searchrec.attr of
$10:
if (searchrec.name<>'.') and (searchrec.name<>'..') then
begin
dorecurse (dir+'\'+searchrec.name);
writeln (dir);
end;
end;
end;

Procedure Dorecurse(dir:string);
var
Searchrec:Tsearchrec;
pc: array[0..79] of Char;

begin
StrPCopy(pc, dir+'\*.*');
FindFirst(pc, FaAnyfile, SearchRec);
Process (dir,SearchRec);
while FindNext(SearchRec)<>-18 do
begin
Process (dir,SearchRec);
end;
end;

Procedure startsearch;
begin
dorecurse (paramstr(1));
end;

begin
startsearch;
end.

[000126]


Инсталляционная директория Win95

function FindWindowsDir : string;
var
pWindowsDir : array [0..255] of Char;
sWindowsDir : string;
begin
// GetWindowsDirectory(LPTSTR,UINT);
// LPTSTR lpBuffer,    // адрес буфера для директории Windows
// UINT uSize          // размер буфера директории
GetWindowsDirectory (pWindowsDir, 255);
sWindowsDir := StrPas (pWindowsDir);
Result := sWindowsDir ;
end;

Дополнение

Пришло письмо от читателя:

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

function GetWindowsFolder:string;
var
TR:TRegIniFile;
HK: HKEY;
begin
RegCreateKey(HKEY_LOCAL_MACHINE,'Software\Microsoft\Windows',HK);
Reg:=TRegIniFile.Create('');
Reg.RootKey:=HK;
GetWinVersion:=Reg.ReadString('CurrentVersion','SystemRoot','');
Reg.Free;
end;

Прислал Igor Popov.
E-mail to: igp@ukrpost.net.

Дополнение

Пришло письмо от читателя:

Я не знаю почему у некоторых не работает GetWindowsDir, ведь это задокументированная MSW -функция, которая есть и в Win95 и в 98. Может помогут эти небольщие ихменения?

function FindWindowsDir : string;
var
pWindowsDir : array [0..MAX_PATH] of Char;
sWindowsDir : string;
begin
// GetWindowsDirectory(LPTSTR,UINT);
// LPTSTR lpBuffer,    // адрес буфера для директории Windows
// UINT uSize          // размер буфера директории
GetWindowsDirectory (@pWindowsDir, MAX_PATH);
sWindowsDir := StrPas (pWindowsDir);
Result := sWindowsDir ;
end;

Этот код работает на ВСЕХ машинах, на которых была запущенна моя прога.

Subfire [000222]


Управление каталогами и файлами

unit win95;
{
Копирование, перемещение и удаление файлов и каталогов наподобие
Проводника (Explorer) в Windows 95.
Дата  : 06/04/97
Последнее обновление: 03/08/97

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

ОБНОВЛЕНИЯ:
(18/04/97)
Множество небольших поправок после множества ваших писем.
Спасибо всем.

(31/08/97)
Две новых процедуры: Win95AddToRecent и
Win95ClearRecentDocs.
}
interface
Uses Classes, ShellApi, ShlObj, Registry, Windows;
type
Str10  = String[10];

Const
fpRootKey ='\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
fpDesktop   : Str10 = 'DESKTOP';
fpFavorites : Str10 = 'FAVORITES';
fpFonts     : Str10 = 'FONTS';
fpPersonal  : Str10 = 'PERSONAL';
fpPrograms  : Str10 = 'PROGRAMS';
fpRecent    : Str10 = 'RECENT';
fpSendTo    : Str10 = 'SENDTO';
fpStartMenu : Str10 = 'START MENU';
fpStartup   : Str10 = 'STARTUP';
fpTemplates : Str10 = 'TEMPLATES';

{Пути к системным папкам}
function GetFolderPath(Const FolderName: Str10): String;

{Функции для работы с файлами}
procedure Win95AddToRecentDocs(Const Filename: string);
procedure Win95ClearRecentDocs;
{Для манипулирования несколькими файлами разделите их имена символом "#0"}
function Win95Copy(Owner: Integer;  FromFile,ToFile: String; RenameOnCollision, Confirm: boolean): Boolean;
function Win95Move(Owner: Integer;  FromFile,ToFile: String; RenameOnCollision, Confirm: boolean): Boolean;
{Если SendToRecycleBin = True, то файлы будут отправлены в Корзину (RecycleBin),
в противном случае они будут стерты}
function Win95Erase(Owner: Integer;  WichFiles: String; SendToRecycleBin, Confirm: Boolean): Boolean;

implementation

function GetFolderPath(Const FolderName: Str10): String;
begin
with TRegistry.Create do
Try
RootKey:=HKEY_CURRENT_USER;
OpenKey(fpRootKey,False);
Result:=ReadString(FolderName);
finally
Free;
end;
end;

procedure Win95AddToRecentDocs(Const Filename: string);
begin
SHAddToRecentDocs(SHARD_PATH, @Filename[1]);
end;

procedure Win95ClearRecentDocs;
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;

function Win95Copy(Owner: Integer; FromFile,ToFile: String; RenameOnCollision, Confirm: boolean): Boolean;
const
Aborted: Boolean = False;
var
Struct : TSHFileOpStructA;
begin
While pos(';',FromFile)>0 do
FromFile[pos(';',FromFile)]:=#0;
While pos(';',ToFile)>0 do
ToFile[pos(';',ToFile)]:=#0;
FromFile:=FromFile+#0#0;
ToFile:=ToFile+#0#0;
with Struct do
begin
wnd         :=Owner;
wFunc       :=FO_Copy;
pFrom       :=PChar(FromFile);
pTo         :=PChar(ToFile);
fFlags:=FOF_ALLOWUNDO or FOF_FILESONLY;
If RenameOnCollision then
fFLags:=fFlags or FOF_RENAMEONCOLLISION;
If not Confirm then
fFLags:=fFlags or FOF_NOCONFIRMATION;
fAnyOperationsAborted:=Aborted;
hNameMappings:=nil;
lpszProgressTitle:=nil;
end;
result:=(SHFileOperationA(Struct)=0) and (not Aborted);
end;

function Win95Move(Owner: Integer;  FromFile,ToFile: String; RenameOnCollision, Confirm: boolean): Boolean;
const
Aborted: Boolean = False;
var
Struct : TSHFileOpStructA;
begin

While pos(';',FromFile)>0 do
FromFile[pos(';',FromFile)]:=#0;
While pos(';',ToFile)>0 do
ToFile[pos(';',ToFile)]:=#0;

FromFile:=FromFile+#0#0;
ToFile:=ToFile+#0#0;
with Struct do
begin
wnd         :=Owner;
wFunc       :=FO_Move;
pFrom       :=PChar(FromFile);
pTo         :=PChar(ToFile);
fFlags:=FOF_ALLOWUNDO or FOF_FILESONLY;
If RenameOnCollision then
fFLags:=fFlags or FOF_RENAMEONCOLLISION;
If Confirm then
fFLags:=fFlags or FOF_NOCONFIRMATION;
fAnyOperationsAborted:=Aborted;
hNameMappings:=nil;
lpszProgressTitle:=nil;
end;
result:=(SHFileOperationA(Struct)=0) and (not Aborted);
end;

function Win95Erase(Owner: Integer;  WichFiles: String;  SendToRecycleBin, Confirm: Boolean): Boolean;
const
Aborted: Boolean = False;
var
Struct : TSHFileOpStructA;
begin
While pos(';',WichFiles)>0 do
WichFiles[pos(';',WichFiles)]:=#0;
WichFiles:=WichFiles+#0#0;
with Struct do
begin
wnd         :=Owner;
wFunc       :=FO_Delete;
pFrom       :=PChar(WichFiles);
pTo         :=nil;
If not Confirm then
fFlags:=FOF_NOCONFIRMATION;
If SendToRecycleBin then
fFLags:=fFlags or FOF_ALLOWUNDO or FOF_FILESONLY
else
fFlags:=fFlags or 0 or FOF_FILESONLY;
fAnyOperationsAborted:=Aborted;
hNameMappings:=nil;
lpszProgressTitle:=nil;
end;
result:=(SHFileOperationA(Struct)=0) and (not Aborted);
end;

end.

[000268]


Путь/Имя папки 'My Computer'

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

Операционная система windows 32 основывается на оболочке, которая использует виртуальные папки, такие, как 'my computer' (Мой компьютер), 'desktop' (Рабочий Стол) и 'recycle bin' (Корзина). Некоторые из них являются частью физической файловой системы. Другими словами, они имеют соответствующий реальный каталог в файловой системе. Это относится, например, к системным папкам 'desktop' и 'recycle bin'. Данные каталоги могут быть использованы как InitialDir в TOpenDialog, но сначала вы должны получить их физическое месторасположение, которое может различаться на других компьютерах. Чтобы узнать их реальное месторасположение на локальном диске, вы должны воспользоваться некоторыми специальными вызовами API (смотри пример ниже). Другие папки, типа 'my computer' и 'printers' не являются частью файловой системы, они чисто виртуальные. Обращаю ваше внимание на то, что такие папки можно использовать в TOpenDialog, но никак не в InitialDir.

Виртуальные папки (я немного упрощаю) имеют тип SHITEMID (идентификатор элемента). Получить к ним доступ можно используя pointers to item identifiers list (PIDL, указатель на элемент списка идентификаторов). Для того, чтобы получить PIDL специальной папки, вы должны использовать функцию SHGetSpecialFolder. Физическое месторасположение соответствующей директории можно получить, передавая PIDL в качестве входного параметра функции GetPathFromIDList. Если папка является частью файловой системы, функция возвращает путь к ней в виде строки (которая впоследствии может использоваться как InitialDir). Но если вы хотите использовать OpenDialog только с виртуальными папками (например, с 'my computer'), то в принципе вы должны использовать PIDL как InitialDir, но это работать не будет. Я думаю дело в том, что TOpenDialog использует PIDLs только для просмотра, а для InitialDir требуются только реальные (физические) каталоги.

Вот пример, показывающий как получить путь к 'recent documents' (последние документы) и использовать его в качестве InitialDir:

procedure TForm1.Button1Click(Sender: TObject);
var
PIDL: Pointer;
Path: LPSTR;
const
CSIDL_RECENT = $0008; begin
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Handle, CSIDL_RECENT, @PIDL);
if SHGetPathFromIDList(PIDL, Path) then // возвращает False если папка
не является частью файловой системы
begin
OpenDialog1.InitialDir := Path;
OpenDialog1.Execute;
end;
StrDispose(Path);
end;

Я думаю вам необходимо создать класс-оболочку для этих вызовов API. Они располагаются в shell32.dll. Наилучший совет, который я могу дать при изучении этого вопроса - копнуть поглубже файл ShlObj.h. Я также не программирую в C, но почерпнул оттуда немало ценной информации.

Вот некоторые константы, которые вам могут понадобиться:

CSIDL_DESKTOP            = $0000;
CSIDL_PROGRAMS           = $0002;
CSIDL_CONTROLS           = $0003;
CSIDL_PRINTERS           = $0004;
CSIDL_PERSONAL           = $0005;
CSIDL_STARTUP            = $0007;
CSIDL_RECENT             = $0008;
CSIDL_SENDTO             = $0009;
CSIDL_BITBUCKET          = $000a;
CSIDL_STARTMENU          = $000b;
CSIDL_DESKTOPDIRECTORY   = $0010;
CSIDL_DRIVES             = $0011;  // Мой компьютер
CSIDL_NETWORK            = $0012;
CSIDL_NETHOOD            = $0013;
CSIDL_FONTS              = $0014;
CSIDL_TEMPLATES          = $0015;

[000280]


Поиск загрузочного диска

Есть какая-либо функция или вызов API для поиска загрузочного диска?

Я нашел это в регистрах:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup

Значение "BootDir" и есть искомая величина. [000285]


Поиск текста в текстовом файле

Кто-нибудь знает быстрый способ поиска строки в текстовом файле?

unit BMSearch;

(* -------------------------------------------------------------------
Поиск строки методом Boyer-Moore.

Это - один из самых быстрых алгоритмов поиска строки.
See a description in:

R. Boyer и S. Moore.
Быстрый алгоритм поиска строки.
Communications of the ACM 20, 1977, страницы 762-772
------------------------------------------------------------------- *)

interface

type
{$ifdef WINDOWS}
size_t = Word;
{$else}
size_t = LongInt;
{$endif}

type
TTranslationTable = array[char] of char;  { таблица перевода }

TSearchBM = class(TObject)
private
FTranslate  : TTranslationTable;     { таблица перевода }
FJumpTable  : array[char] of Byte;   { таблица переходов }
FShift_1    : integer;
FPattern    : pchar;
FPatternLen : size_t;

public
procedure Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean );
procedure PrepareStr( const Pattern: string; IgnoreCase: Boolean );

function  Search( Text: pchar; TextLen: size_t ): pchar;
function  Pos( const S: string ): integer;
end;

implementation

uses  SysUtils;

(* -------------------------------------------------------------------
Игнорируем регистр таблицы перевода
------------------------------------------------------------------- *)
procedure CreateTranslationTable( var T: TTranslationTable; IgnoreCase: Boolean );
var
c: char;
begin
for c := #0 to #255 do
T[c] := c;

if not IgnoreCase then
exit;

for c := 'a' to 'z' do
T[c] := UpCase(c);

{ Связываем все нижние символы с их эквивалентом верхнего регистра }

T['Б'] := 'A';
T['А'] := 'A';
T['Д'] := 'A';
T['В'] := 'A';

T['б'] := 'A';
T['а'] := 'A';
T['д'] := 'A';
T['в'] := 'A';

T['Й'] := 'E';
T['И'] := 'E';
T['Л'] := 'E';
T['К'] := 'E';

T['й'] := 'E';
T['и'] := 'E';
T['л'] := 'E';
T['к'] := 'E';

T['Н'] := 'I';
T['М'] := 'I';
T['П'] := 'I';
T['О'] := 'I';

T['н'] := 'I';
T['м'] := 'I';
T['п'] := 'I';
T['о'] := 'I';

T['У'] := 'O';
T['Т'] := 'O';
T['Ц'] := 'O';
T['Ф'] := 'O';

T['у'] := 'O';
T['т'] := 'O';
T['ц'] := 'O';
T['ф'] := 'O';

T['Ъ'] := 'U';
T['Щ'] := 'U';
T['Ь'] := 'U';
T['Ы'] := 'U';

T['ъ'] := 'U';
T['щ'] := 'U';
T['ь'] := 'U';
T['ы'] := 'U';

T['с'] := 'С';
end;

(* -------------------------------------------------------------------
Подготовка таблицы переходов
------------------------------------------------------------------- *)

procedure TSearchBM.Prepare( Pattern: pchar; PatternLen: size_t;
IgnoreCase: Boolean );
var
i: integer;
c, lastc: char;
begin
FPattern := Pattern;
FPatternLen := PatternLen;

if FPatternLen < 1 then
FPatternLen := strlen(FPattern);

{ Данный алгоритм базируется на наборе из 256 символов }

if FPatternLen > 256 then
exit;

{ 1. Подготовка таблицы перевода }

CreateTranslationTable( FTranslate, IgnoreCase);

{ 2. Подготовка таблицы переходов }

for c := #0 to #255 do
FJumpTable[c] := FPatternLen;

for i := FPatternLen - 1 downto 0 do begin
c := FTranslate[FPattern[i]];
if FJumpTable[c] >= FPatternLen - 1 then
FJumpTable[c] := FPatternLen - 1 - i;
end;

FShift_1 := FPatternLen - 1;
lastc := FTranslate[Pattern[FPatternLen - 1]];

for i := FPatternLen - 2 downto 0 do
if FTranslate[FPattern[i]] = lastc  then begin
FShift_1 := FPatternLen - 1 - i;
break;
end;

if FShift_1 = 0 then
FShift_1 := 1;
end;

procedure TSearchBM.PrepareStr( const Pattern: string; IgnoreCase: Boolean );
var
str: pchar;
begin
if Pattern <> '' then begin
{$ifdef Windows}
str := @Pattern[1];
{$else}
str := pchar(Pattern);
{$endif}

Prepare( str, Length(Pattern), IgnoreCase);
end;
end;

{ Поиск последнего символа & просмотр справа налево }

function TSearchBM.Search( Text: pchar; TextLen: size_t ): pchar;
var
shift, m1, j: integer;
jumps: size_t;
begin
result := nil;
if FPatternLen > 256 then
exit;

if TextLen < 1 then
TextLen := strlen(Text);

m1 := FPatternLen - 1;
shift := 0;
jumps := 0;

{ Поиск последнего символа }

while jumps <= TextLen do begin
Inc( Text, shift);
shift := FJumpTable[FTranslate[Text^]];
while shift <> 0 do begin
Inc( jumps, shift);
if jumps > TextLen then
exit;

Inc( Text, shift);
shift := FJumpTable[FTranslate[Text^]];
end;

{ Сравниваем справа налево FPatternLen - 1 символов }

if jumps >= m1 then begin
j := 0;
while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do begin
Inc(j);
if j = FPatternLen then begin
result := Text - m1;
exit;
end;
end;
end;

shift := FShift_1;
Inc( jumps, shift);
end;
end;

function TSearchBM.Pos( const S: string ): integer;
var
str, p: pchar;
begin
result := 0;
if S <> '' then begin
{$ifdef Windows}
str := @S[1];
{$else}
str := pchar(S);
{$endif}

p := Search( str, Length(S));
if p <> nil then
result := 1 + p - str;
end;
end;

end.

[000305]


Быстрое копирование файла

procedure CopyFile( Source, Dest : string );
var
SrcFile : Integer;
DestFile : Integer;
S : string;
RetCode : Longint;
OpenFileBuf   : TOFStruct;
FName : array[ 0..255 ] of Char;
begin
StrPCopy( FName, Source );
SrcFile := LZOpenFile( FName, OpenFileBuf, of_Read );
StrPCopy( FName, Dest );
DestFile := LZOpenFile( FName, OpenFileBuf, of_Create );

RetCode := LZCopy( SrcFile, DestFile );
if RetCode >= 0 then
begin
LZClose( SrcFile );
LZClose( DestFile );
end
else
begin
Str( RetCode, S );
MessageDlg( 'Не могу скопировать ' + Source + ' в ' +
Dest + #13 + 'Код ошибки = ' + S, mtError, [mbOk], 0 );
end;
end;

[000351]


Блокировка файла

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

type FileShareType = (DenyCompatibility,DenyAll,DenyWrite,DenyRead,DenyNone);
FileAccessType = (ReadOnly,WriteOnly,ReadWrite);

procedure SetFileAccess(AccessMode: FileAccessType;ShareMode: FileShareType);
{ Устанавливаем режим доступа к файлу для следующего вызова открытия файла }
begin
FileMode := ord(AccessMode) or (ord(ShareMode) shl 4)
end;

Вот и все. [000367]


LZCopy

Вот простой пример копирования файла (сжатого или нет):

Var
srcHandle, destHandle: Integer;
srcBuf, destBuf: TOFStruct;

srcHandle := LZOpenFile( f_source, srcBuf,
OF_READ or OF_SHARE_DENY_NONE );
If srcHandle = -1 Then
CopyFailed
Else Begin
destHandle := LZOpenFile( f_target, destBuf,
OF_CREATE or OF_SHARE_EXCLUSIVE );
If destHandle = -1 Then
CopyFailed
Else Begin
If LZCopy( srcHandle, destHandle ) < 0 Then
CopyFailed;
LZClose( destHandle );
End; { Else }
LZClose( srcHandle );
End; { Else }

f_source и f_target - указатели на терминированные нулем строки (PChars) с именем исходного и целевого файла. CopyFailed - просто процедура для вывода сообщения об ошибке, создайте ее сами.

Если вам необходимо скопировать сразу несколько файлов, эффективнее использовать последовательность:

LZStart;
For i:=1 to numSourcefiles Do Begin
scrHandle := _lopen( имя исходного файла ... );
targetHandle := _lcreat( имя целевого файла... );
CopyLZFile( scrHandle, targetHandle );
_lclose( srcHandle );
_lclose( targetHandle );
End;
LZDone;
(* добавьте проверку на ошибку в каждом шаге! *)

Все имена файлов должны терминироваться нулем, не используйте паскалевские строки! Самый простой путь для добавления нуля в конец строки - добавление символа #0 и передача адреса первого символа строки, например (@str[1]).

Var
source: string;
sourceHandle: Word;

....
source:= 'a:\anyfile.ext';
....
source := source+#0;
sourceHandle := _lopen( @source[1], READ or OF_SHARE_DENY_NONE );

[000373]


Одной строкой

Файловые переменные

Вы просто создаете файловую переменную, чей тип является 'File of ...', где ... - ваша структура записи. Пример:

var
F : File of TMyRec;
R : TMyRec;
begin
{ Заполнение записи R }

AssignFile( F, 'somefile.dat' );
Rewrite( F );
Write( F, R );
CloseFile( F );
end;

Later,
Ray Konopka
Raize Software Solutions [000384]


Одной строкой

Доступ к нетипизированному файлу

Вы можете организовать доступ к файлу "без определенного типа" следующим образом:

Var MyFile : file;
begin
assign(MyFile,Filename);
reset(MyFile,1);
{для записи}
Blockwrite(MyFile,item,sizeof(item));
{для чтения}
BlockRead(MyFile,item,sizeof(item));

close(MyFile);
end;

Имейте в виду, что для чтения/записи нетипизированного файла необходимо использовать функции blockread и blockwrite, т.к. для использования нормальных функций Read/Write компилятору необходимо знать формат файла. [000519]


Управление атрибутом файла date/time

"Могу ли я написать функцию, которая устанавливает дату одного файла, равную дате другого файла?"

Не проблема. Используйте следующую функцию, использующую в качестве параметров две строки с полными путями/именами файлов DOS. Файл, дату которого вы хотите установить идет вторым параметром, файл, чью дату вы хотите использовать - первым.

procedure CopyFileDate(const Source, Dest: String);
var
SourceHand, DestHand: word;
begin
SourceHand := FileOpen(Source, fmOutput);       { открываем исходный файл }
DestHand := FileOpen(Dest, fmInput);            { открываем целевой файл }
FileSetDate(DestHand, FileGetDate(SourceHand)); { получаем/устанавливаем дату }
FileClose(SourceHand);                          { закрываем исходный файл }
FileClose(DestHand);                            { закрываем целевой файл }
end;

[000534]


Delphi 1

Установка режима бинарного файла

Попробуйте вызвать приведенную ниже процедуру немедленно после перезаписи выходного файла и перед началом записи в него:

procedure SetBinaryMode (var F: file);  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 [000603]


Delphi 1

Как мне открыть файл общего доступа?

Какие предложения по открытию файла общего доступа из Delphi-приложения?

Проверьте переменную FileMode и сравните ее значение с приведенным ниже списком:

Const
fmReadOnly  = $00;
fmWriteOnly = $01;
fmReadWrite = $02;

fmDenyAll   = $10;
fmDenyWrite = $20;
fmDenyRead  = $30;
fmDenyNone  = $40;

fmNoInherit = $80;

Вы можете использовать их совместно, например так:

FileMode := fmReadWrite + fmDenyAll;

или так:

FileMode := fmReadOnly + fmDenyNone;

Успехов,
Dr. Bob (drbob@pi.net) [000723]


Удаление непустого каталога

Пришло письмо от читателя:

Здравствуйте

Вот, понадобилась мне процедурка удаления непустого каталога. Нашел, не помню где. Включил в програму, работала, пока не стал использовать длинные имена каталогов (без пробелов, кстати). NT стала операцию выполнять, но криво (возбуждала исключение). Окончательно:

procedure TForm1.deletedirectory(dir:string);
var
sh:SHFILEOPSTRUCT;
st:string;
sr:tsearchrec;
pst:pchar;
begin
if findfirst(dir,faDirectory,sr)=0 then begin

//added by me
dir:=longtoshortfilename(dir);
//original code
sh.Wnd:= Form1.handle;
sh.wFunc:= FO_DELETE;
Pst:=StrAlloc(Length(dir{sr.Name})+1);
StrPLCopy(Pst,dir{sr.Name},Length(dir{sr.Name})+1);
sh.pFrom:=pst;
sh.pTo:= Nil;
sh.fFlags:= FOF_NOCONFIRMATION or FOF_SILENT;
sh.hNameMappings:= Nil;
sh.lpszProgressTitle:= Nil;

SHFileOperation(sh);

StrDispose(Pst);
end;

findclose(sr);
end;

С уважением, Александр Рабцевич [000744]


Delphi 1

BlockRead и текстовый файл

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

Примечание: В процессе обработки, если длина строки выходного файла превышает 255 символов и вы хотите прочесть ее с помощью ReadLn, то просто используйте в запросе ReadLn несколько строк, например так:

ReadLn(infile,string1,string2);

Так можно прочесть вплоть до 510 символьных строк с 1-й по 255 символ в string1 и остальное в string2;

program fixfile;{ Компилируем из DOS-приглашения:  DCC FIXFILE.PAS }
uses            { запускаем из File Manager }
sysutils,dialogs,forms;

type
bufptr =     obufr;
iobufr = array[0..16384] of char;

var
infile : file;
oufile : textfile;
inbufr,
oubufr : bufptr;

idx: integer;
bytesread: integer;
bytes2read: integer;

totalbytesread: longint;
actualfilesize: longint;

OpenDialog1: TOpenDialog;

infilename,
oufilename: string;

begin

infilename := '';
OpenDialog1 := TOpenDialog.Create(Application);

OpenDialog1.Options := [];
OpenDialog1.Filter := 'Все файлы|*.*';
OpenDialog1.FilterIndex := 1;
OpenDialog1.Title := 'Укажите исходный файл для преобразования';
if OpenDialog1.execute then
infilename := OpenDialog1.filename;

if infilename='' then
begin
OpenDialog1.free;
halt;
end;

OpenDialog1.Title := 'Укажите имя создаваемого целевого файла';
if OpenDialog1.execute then
oufilename := OpenDialog1.filename;

OpenDialog1.free;

if oufilename='' then
halt;

if infilename=oufilename then
halt;

new(inbufr);
new(oubufr);

assignfile(infile,infilename);
reset(infile,1);
actualfilesize := filesize(infile);

assignfile(oufile,oufilename);
system.settextbuf(oufile,oubufr^);
rewrite(oufile);

totalbytesread := 0;
bytesread  := 0;
bytes2read := 0;

while (totalbytesread<actualfilesize)
and  (bytes2read=bytesread) and (IOresult=0) do
begin
if (actualfilesize-totalbytesread)>sizeof(inbufr^) then
bytes2read := sizeof(inbufr^)
else
bytes2read := actualfilesize-totalbytesread;

blockread(infile,inbufr^,bytes2read,bytesread);

totalbytesread := totalbytesread + bytesread;
for idx := 0 to bytesread do
if inbufr^ [idx]='''' then   { <= преобразуемый символ }
writeln(oufile)
else
write(oufile,inbufr^ [idx]);
end;

closefile(infile);
closefile(oufile);

dispose(inbufr);
dispose(oubufr);

end.

- Dennis Passmore [000755]


Readln для более чем 255 символов

Как мне воспользоваться функцией readln(), если файл содержит строки с более чем 255 символами?

ReadLn акцептует массив символов array [0..something] of Char и использует его в качестве буфера для чтения символов, замыкая цепочку терминирующим нулем. Единственное ограничение: компилятор должен иметь возможность вычисления размера буфера во время компиляции, что делает невозможным объявление переменой типа PChar и ее распределение во время выполнения программы.

Обходной путь:

Type
{используем самое большое количество символов в строке, с которым вы можете иметь дело}
TLine = Array [0..1024] of Char;

PLine = ^TLine;

Var
pBuf: PLine;
...
New( pBuf );

...
ReadLn( F, pBuf^ );

Для передачи pBuf функциям, которым требуется параметр типа Pchar, используйте приведение типа подобно PChar( pBuf ).

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

[000838]


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

type
TByteSet = set of byte ;

procedure ProcessFile( const InFileName,OutFileName: string; Valid: TByteSet ) ;
var
InFile, OutFile : file ;
InBuf, OutBuf   : PByteArray ;
InPos, OutPos   : word ;
BytesRead       : word ;
begin
OutBuf := NIL ;
New( InBuf ) ;
try
New( OutBuf ) ;
AssignFile( InFile, InFileName ) ;
AssignFile( OutFile, OutFileName ) ;
Reset( InFile, 1 ) ;
Rewrite( OutFile, 1 ) ;
repeat
Blockread( InFile, InBuf^, SizeOf( InBuf^ ), BytesRead ) ;
OutPos := 0 ;
for InPos := 0 to BytesRead - 1 do begin
if InBuf^[ InPos ] in Valid then begin
inc( OutPos ) ;
end ;
end ;
if OutPos > 0 then BlockWrite( OutFile, OutBuf^, OutPos ) ;
until BytesRead <> SizeOf( InBuf^ ) ;
CloseFile( InFile ) ;
CloseFile( OutFile ) ;
finally
if OutBuf <> NIL then Dispose( OutBuf ) ;
Dispose( InBuf ) ;
end ;
end;

Применять это можно приблизительно так:

ProcessFile( 'SOURCE.RAW', 'NEW.RAW', [ 10, 13, 32..255 ] ) ;

- Mike Scott [000865]


Изменение расширения BITMAP???

Я изменил расширение изображения с BMP на 3LG. Затем для загрузки *.3LG-файла в виде изображения в компонент Image1 я даю команду

Image1.Picture.LoadFromFile('C:\TEST.3LG');

я получаю ошибку, говорящую о неверном расширении. Как мне обойти это? (это тот же BMP, но я просто изменил ему расширение)

Смотри процедуру RegisterFileFormat.

- Steve Schafer [000998]


Сообщения Windows - введение

Кто-нибудь может со мной поделиться информацией о работе в Delphi с Windows Messages (системные сообщения)? Все эти сообщения типа WM_*** вызывают у меня нервный тик, поскольку это я не могу понять как это работает.

Список всех системных сообщений Windows доступен в файлах электронной справки Delphi. (Я использую D5, но думаю в будущих версиях все останется на своих местах).

Сообщения WM_ (и другие) играют существенную роль в работе Windows. Все вы хорошо знаете, что Delphi первоначально строится на принципе *управления событиями*; наверняка не один раз вы создавали обработчики событий OnKeyPress, OnThis, OnThat и других. Если у вас есть исходный код VCL, вы легко обнаружите, что механизм работы событий в Delphi основан на обработке конкретных системных соощенияй, посылаемых вашему элементу управления (как раз здесь и заложено главное достоинство объектно-ориентированного программирования, когда вы можете создать новый компонент на основе существующего и "научить" его обрабатывать другие необходимые вам системные сообщения). Windows постоянно посылает сообщения в ответ на действия пользователя и ждет соответствующей реакции от приложений Delphi (и всех остальных приложений Windows), заключающейся в их "приеме" и соответствующей обработке. Delphi имеет оболочки для большинства системных сообщений, создав "механизм оповещения элемента управления о приеме сообщения на его адрес" - события для компонентов, как было описано выше.

Кроме приема сообщений, у вас также существует возможность их отправления. Это возможно двумя способами: SendMessage и PostMessage (обе являются Win API функциями), а также метод Delphi Perform. Первые два требуют в качестве параметра Handle указывать дескриптор компонента, которому вы шлете сообщение, тогда как Perform является методом, принадлежащим самому компоненту. Сообщения передаются в стандартную очередь системных сообщений и обрабатываются подобно другим сообщениям.

Вот тривиальный пример: я хочу (по некоторой причудливой причине) вставлять в TMemo символ 'y' каждый раз после набора цифры '4'. (Обдумайте способ автоматической вставки блока begin-end или заключительной скобки.) Я, конечно, мог бы поработать с Memo-свойством Lines, но это было бы не так красиво и достаточно громоздко. Вот как выглядит наш пример с использованием сообщений:

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
if Key = '4' then
SendMessage(Memo1.Handle, WM_CHAR, Word('y'), 0);
end;

Другой пример демонстрирует работу с компонентом ComboBox. Мы хотим, чтобы он автоматически выпадал при нажатии пользователем какой-либо клавиши. Это поведение, к сожалению, нестандартно. Вот что мы делаем:

procedure TFormEffortRates.ComboBoxMaterialKeyDown(Sender: TObject; var
Key: Word;
Shift: TShiftState);
var iShowing : integer;

{ какой-то код, затем... }
begin
{ С помощью сообщения узнаем состояние ("раскрытость") ComboBox'а }
iShowing := SendMessage((Sender as TComboBox).Handle, CB_GETDROPPEDSTATE, 0, 0);
if iShowing = 0 then
{ раскрываем ComboBox }
SendMessage((Sender as TComboBox).Handle, CB_SHOWDROPDOWN, 1,0);
end;

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

function TMDIChild.GetMemoColumn(const TheMemo : TMemo) : integer;
begin
Result := TheMemo.SelStart -
(SendMessage(TheMemo.Handle, EM_LINEINDEX,
GetMemoLine(TheMemo), 0));
end;

function TMDIChild.GetMemoLine(const TheMemo : TMemo) : integer;
begin
Result := SendMessage(TheMemo.Handle, EM_LINEFROMCHAR,
TheMemo.SelStart, 0);
end;

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

Короче говоря, сообщения API позволяют тонко управлять вашими приложениями, выполняя именно те задачи, которые вам необходимо решить (метод "точечной наводки"). Вам необходимо лишь выбрать цель и передать свою просьбу понравившемуся элементу управления (или самому ловить такие сообщения). [000288]


Delphi 1

Рисование на минимизированной иконке

Есть ли у кого пример рисования на иконке минимизированного приложения с помощью Delphi?

Когда Delphi-приложение минимизировано, иконка, которая вы видите - реальное главное окно, объект TApplication, поэтому вам необходимо использовать переменную Application. Таким образом, чтобы удостовериться что приложение минимизировано, вызовите IsIconic(Application.Handle). Если функция возвратит True, значит так оно и есть. Для рисования на иконке создайте обработчик события Application.OnMessage. Здесь вы можете проверять наличие сообщения WM_Paint и при его нахождении отрисовывать иконку. Это должно выглядеть приблизительно так:

...
{ private declarations }
procedure AppOnMessage(VAR Msg : TMsg; VAR Handled : Boolean);
...

procedure TForm1.AppOnMessage(VAR Msg : TMsg; VAR Handled : Boolean);
VAR
DC : hDC;
PS : TPaintStuff;
begin
IF (Msg.Message = WM_PAINT) AND IsIconic(Application.Handle) THEN
BEGIN
DC := BeginPaint(Application.Handle, PS);
... осуществляем отрисовку с помощью вызовов Windows GDI ...

EndPaint(Application.Handle, PS);
Handled := True;
END;
end;

procedure TForm1.OnCreate(Sender : TObject);
begin
Application.OnMessage := AppOnMessage;
end;

Код создан на основе алгоритма Neil Rubenking.

Nick Hodges
Monterey, CA [000605]


Delphi 1

Сохранение приложения в виде иконки

Как мне после запуска сохранять все время приложение в виде иконки?
  1. В свойствах формы вы должны установить WindowState на wsMinimized.
  2. В секции класса формы private поместите следующее объявление:

    ...
    { private declarations }
    PROCEDURE WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN;

  3. В секции implementation поместите следующую реализацию метода:
    PROCEDURE TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen);
    begin
    Msg.Result := 0;
    end;

Это все! Форма всегда будет иконкой. [000625]


Регистры - доступ и использование вместо WIN.INI

uses
Registry, Windows;

var
TheReg: TRegistry;
KeyName: String;
ValueStr: String;

begin
TheReg := TRegistry.Create;
try
TheReg.RootKey := HKEY_CURRENT_USER;
KeyName := 'Software\MyTinyApp\StartUp';
if TheReg.OpenKey(KeyName, False) then
begin
ValueStr := TheReg.ReadString('WorkPath');
TheReg.CloseKey;
end;
finally
TheReg.Free;
end;
end;

Также имейте в виду, что корректное место для сохранения пути к вашему приложению (EXE-файлу) в регистрах Win95 находится по адресу:

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\AppPaths\MYAPP.EXE

Сохраните полный путь к вашему приложению как значение по умолчанию в этом ключе.

Regstr.pas определяет константу для этого пути (...\App Paths\) как REGSTR_PATH_APPPATHS.

Сохранение полного пути к вашему приложению (EXE-файлу) позволит пользователю запустить его, просто набрав MYAPP (зарегистрированное имя) в стартовом меню Start|Run. Вот пример, регистрирующий путь к вашему приложению:

uses
Registry, Regstr;

var
TheReg: TRegistry;
KeyName: String;

begin
TheReg := TRegistry.Create;
try
{Проверяем установку AppPath и при необходимости корректируем}
TheReg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := REGSTR_PATH_APPPATHS + ExtractFileName(Application.ExeName);
if TheReg.OpenKey(KeyName, True) then
begin
if CompareText(TheReg.ReadString(''), Application.ExeName) <> 0 then
TheReg.WriteString('', Application.ExeName);
TheReg.CloseKey;
end;
finally
TheReg.Free;
end;
end;

[000220]


Как мне получить из регистров информацию о временной зоне (DST)?

HKEYLocal Machine/Software/Microsoft/Windows/CurrentVersion/TimeZones/ - место, где в регистре хранится информация о временных зонах (Timezone). Двоичный код 'TZI' хранит информацию о начале и конце летнего времени. Есть какие-нибудь идеи насчет извлечения этих дат из этой двоичной величины?

Ок, попробую здесь описать бинарную структуру значения TZI:

int32 Bias;             // Минуты от GMT
                        // (Сидней -600; 0xfffffda8;
                        // или a8, fd, ff, ff)
int32 StandardBias;     // Смещение для стандартного времени (0)
int32 DaylightBias;     // Смещение для летнего времени (-60
                        // или 0xffffffc4 )
int16 ??                          // 0
int16 StandardStartMonth;         // 3 => Март
int16 StandardStartDayOfWeek??;   // 0 => Воскресенье
int16 StandardStartDOWoccurrence; // 1 => 1-й
int16 StandardStartHour;          // 2 => 02:00:00.00
int16 StandardStartMins??;        // 0 => 02:00:00.00
int16 StandardStartSecs??;        // 0 => 02:00:00.00
int16 StandardStartHunds??;       // 0 => 02:00:00.00
int16 ??                          // 0
int16 DaylightStartMonth;         // 0x0a (10) => Октябрь
int16 DaylightStartDayOfWeek??;   // 0 => Воскресенье
int16 DaylightStartDOWoccurrence; // 5 => последний
int16 DaylightStartHour;          // 2 => 02:00:00.00
int16 DaylightStartMins??;        // 0 => 02:00:00.00
int16 DaylightStartSecs??;        // 0 => 02:00:00.00
int16 DaylightStartHunds??;       // 0 => 02:00:00.00
[000223]


Объекты и Tregistry

Кто-нибудь знает, как сохранить общие настройки шрифтов моей формы/пенели/списка и пр. пр. в регистрах; конечно, можно легко обойтись построчным сохранением, но, к примеру, в случае сохранения свойств шрифтов количество строк выйдет за пределы разумного - кто нибудь может подсказать мне решение покороче и полегче?

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

uses TypInfo;

{ Определяем тип-набор для доступа к битам целого. }
const
BitsPerByte = 8;
type
TIntegerSet = set of 0..SizeOf(Integer)*BitsPerByte - 1;

{ Сохраняем набор свойств в виде подключа. Каждый элемент перечислимого типа -
отдельная логическая величина. Истина означает что элемент включен в набор,
Ложь - элемент в наборе отсутствует. Это позволит пользователю
с помощью редактора ресурсов (REGEDIT) легко изменять конфигурацию. }
procedure SaveSetToRegistry(const Name: string; Value: Integer;
TypeInfo: PTypeInfo; Reg: TRegistry);
var
OldKey: string;
I: Integer;
begin
TypeInfo := GetTypeData(TypeInfo)^.CompType;
OldKey := '\' + Reg.CurrentPath;
if not Reg.OpenKey(Name, True) then
raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
[Name]);

{ Организуем цикл для всех элементов перечислимого типа. }
with GetTypeData(TypeInfo)^ do
for I := MinValue to MaxValue do
{ Записываем логическую величину для каждого установленного элемента. }
Reg.WriteBool(GetEnumName(TypeInfo, I), I in
TIntegerSet(Value));

{ Возвращаем родительский ключ. }
Reg.OpenKey(OldKey, False);
end;

{ Сохраняем объект в регистрах в отдельном подключе. }
procedure SaveObjToRegistry(const Name: string; Obj: TPersistent;
Reg: TRegistry);
var
OldKey: string;
begin
OldKey := '\' + Reg.CurrentPath;
{ Открываем подключ для объекта. }
if not Reg.OpenKey(Name, True) then
raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
[Name]);

{ Сохраняем свойства объекта. }
SaveToRegistry(Obj, Reg);

{ Возвращаем родительский ключ. }
Reg.OpenKey(OldKey, False);
end;

{ Сохраняем в регистрах метод путем записи его имени. }
procedure SaveMethodToRegistry(const Name: string; const Method:
TMethod;
Reg: TRegistry);
var
MethodName: string;
begin
{ Если указатель на метод содержит nil, сохраняем пустую строку. }
if Method.Code = nil then
MethodName := ''
else
{ Находим имя метода. }
MethodName := TObject(Method.Data).MethodName(Method.Code);
Reg.WriteString(Name, MethodName);
end;

{ Сохраняем в регистре каждое свойство в виде значения текущего
ключа. }
procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;
Reg: TRegistry);
begin
with PropInfo^ do
case PropType^.Kind of
tkInteger,
tkChar,
tkWChar:
{ Сохраняем порядковые свойства в виде целочисленного значения. }
Reg.WriteInteger(Name, GetOrdProp(Obj, PropInfo));
tkEnumeration:
{ Сохраняем имена перечислимых величин. }
Reg.WriteString(Name, GetEnumName(PropType, GetOrdProp(Obj,
PropInfo)));
tkFloat:
{ Сохраняем реальные числа как Doubles. }
Reg.WriteFloat(Name, GetFloatProp(Obj, PropInfo));
tkString,
tkLString:
{ Сохраняем строки как строки. }
Reg.WriteString(Name, GetStrProp(Obj, PropInfo));
tkVariant:
{ Сохраняем вариантные величины как строки. }
Reg.WriteString(Name, GetVariantProp(Obj, PropInfo));
tkSet:
{ Сохраняем набор как подключ. }
SaveSetToRegistry(Name, GetOrdProp(Obj, PropInfo), PropType,
Reg);
tkClass:
{ Сохраняем класс как подключ, а его свойства
в виде значений подключа. }
SaveObjToRegistry(Name, TPersistent(GetOrdProp(Obj, PropInfo)),
Reg);
tkMethod:
{ Сохраняем в регистрах метод путем записи его имени. }
SaveMethodToRegistry(Name, GetMethodProp(Obj, PropInfo), Reg);
end;
end;

{ Записываем объект в регистр, сохраняя опубликованные свойства. }
procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry);
var
PropList: PPropList;
PropCount: Integer;
I: Integer;
begin
{ Получаем список опубликованных свойств. }
PropCount := GetTypeData(Obj.ClassInfo)^.PropCount;
GetMem(PropList, PropCount*SizeOf(PPropInfo));
try
GetPropInfos(Obj.ClassInfo, PropList);
{ Сохраняем каждое свойство в виде значения текущего ключа. }
for I := 0 to PropCount-1 do
SavePropToRegistry(Obj, PropList^[I], Reg);
finally
FreeMem(PropList, PropCount*SizeOf(PPropInfo));
end;
end;

{ Сохраняем опубликованные свойства в виде значения данного ключа.
Корневой улей - HKEY_CURRENT_USER. }
procedure SaveToKey(Obj: TPersistent; const KeyPath: string);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
if not Reg.OpenKey(KeyPath, True) then
raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
[KeyPath]);
SaveToRegistry(Obj, Reg);
finally
Reg.Free;
end;
end;

[000225]


Ассоциирование типов файлов (расширений)

В основном вам необходимо добавить два ключа в улей регистра HKEY_CLASSES_ROOT. Зарегистрируете в корне ваше расширение типа ".ext" (создаете ключ с именем расширения):

HKEY_CLASSES_ROOT\
.ext\

и запишите в строке "default" созданного ключа "внутреннее имя" вашего типа файлов - например, MyApp.Document:

HKEY_CLASSES_ROOT\
.ext\
Default = "MyApp.Document"

Затем создайте другой ключ с этим именем:

HKEY_CLASSES_ROOT\
MyApp.Document\

Создайте подключ с именем "shell", в нем другой подключ с именем "open" и в "open", в свою очередь, еще один подключ с именем "command". Значение по умолчанию (default) - путь и имя вашего приложению с ключом "%1", представляющим параметр "имя файла", позволяя системе подставлять подставлять вызванный файл:

HKEY_CLASSES_ROOT\
MyApp.Document\
shell\
open\
command\
Default = "C:\myapp\myapp.exe %1"

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

Вот еще один совет:

Самый простой путь достижения цели - модифицировать секцию Extensions в win.ini-файле, расположенном с директории Windows. Это также работает под Win 95, автоматически обновляя регистры при перезапуске системы. Взгляните на секцию Extensions win.ini-файла для определения формата записи. Поместите IniFiles в секцию используемых модулей и создайте код подобно этому:

var
INIFile: TIniFile;
begin
try
INIFile := TInifile.Create('WIN.INI');
INIFile.WriteString('Extensions','txt','c:\windows\notepad.exe ^.txt');
finally
INIFile.Free;
end;
end;

Это ассоциирует файлы с расширением *.txt с Записной Книжкой (Notepad) Windows. Например, для ассоциации вашего приложения MyApp с каталогом расположения c:\MyApps с файлами, имеющими расширение *.MAP, необходимо выполнить следующее:

var
INIFile: TIniFile;
begin
try
INIFile := TInifile.Create('WIN.INI');
INIFile.WriteString('Extensions','map','c:\myapps\myapp.exe ^.map');
finally
INIFile.Free;
end;
end;

Это будет работать как в Win 3.11, так и в Win 95 и избавит вас от работы с регистрами в Win 95. Не уверен насчет Win NT (или Win98), поскольку у меня нет возможности протестировать это дома. Имейте в виду, что все вышеописанное - только часть проблемы, т.к. приложение после всех вышеуказанных манипуляций еще должно этот файл открыть. Для этого вы должны прочесть ParamStr(1), содержащий полный путь к файлу, выбранному пользователем, и должным образом загрузить его в свое приложение.

Дополнение

Михаил Шпанер продолжает эту тему:

Чтобы описание типа файлов появилось в списке "Типы файлов" Windows 98, укажите в параметре "default" ключа 'HKEY_CLASSES_ROOT\MyApp.Document\' краткое описание типа файлов (файл My App).

Чтобы ассоциированные файлы имели соответствующую приложению иконку, нужно в параметре "default" ключа 'HKEY_CLASSES_ROOT\ MyApp.Document\DefaultIcon\' указать путь к иконке. Иконки соответствующих файлов обновятся после перезагрузки Windows. Windows 98 делает это без перезагрузки системы, но как это сделать я не знаю, может быть кто-то подскажет.

Пример кода (проверено в Delphi5, Windows98):

Добавьте 'Registry' в строку Uses.

Объявите переменную 'RegFile':

var
RegFile : TRegIniFile;

begin
RegFile:=TRegIniFile.Create;

RegFile.RootKey:=HKEY_CLASSES_ROOT; //устанвливаем текущий ключ
RegFile.WriteString('.ext','','MyApp.Document'); //  определяем расширение
RegFile.WriteString('MyApp.Document','','Описание файлов');//Описание ассоциированных файлов (для списка "Типы файлов" Windows 98).
RegFile.WriteString('MyApp.Document \DefaultIcon','','Путь к иконе для файлов');//устанавливаем икону для ассоциированных файлов
//Исполняемый файл (полный путь)
RegFile.WriteString(' MyApp.Document \Shell\Open\Command','','исполняемый файл "%1" ');

RegFile.CloseKey;
RegFile.Free;
End;

С уважением Михаил Шпанер. [000291]


Как создавать ярлыки (shortcuts)?

Техническая документация Borland (Borland Tech Doc) #3234

Данный демо-проект демонстрирует простое решение для добавления ярлыков (Shortcuts) на рабочий стол или в главное меню Windows 95 или Windows NT 4.0.

  1. Запустите Delphi.
  2. Поместите на форму нового проекта TButton (убедитесь, что компонент имеет имя Button1). Щелкните два раза на Button1. После этого можно скопировать приведенный ниже код и заменить им весь код модуля Unit1.
Программа создаст ярлык на рабочем столе или (смотри код) в главном меню. Ярлык будет иметь имя FooBar и при щелчке загрузит ваш AUTOEXEC.BAT в блокнот (NOTEPAD).

Код читает строковое значение из ключей регистра "Desktop" и "Start Menu" (ветка HKEY_CURRENT_USER), полный путь к которым:

Software\MicroSoft\Windows\CurrentVersion\Explorer\Shell Folders

-------------
Модуль Unit1
-------------

unit Unit1;

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

{$R *.DFM}

uses
ShlObj, ActiveX, ComObj, Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
MyObject  : IUnknown;
MySLink   : IShellLink;
MyPFile   : IPersistFile;
FileName  : String;
Directory : String;
WFileName : WideString;
MyReg     : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
FileName := 'NOTEPAD.EXE';
with MySLink do begin
SetArguments('C:\AUTOEXEC.BAT');
SetPath(PChar(FileName));
SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
end;
MyReg := TRegIniFile.Create(
'Software\MicroSoft\Windows\CurrentVersion\Explorer');

// Используйте следующую строчку кода для создания ярлыка на рабочем столе
Directory := MyReg.ReadString('Shell Folders','Desktop','');

// Используйте следующие три строчки для создания ярлыка в главном меню
//  Directory := MyReg.ReadString('Shell Folders','Start Menu','')+
//      '\Рулез!';
//  CreateDir(Directory);

WFileName := Directory+'\FooBar.lnk';
MyPFile.Save(PWChar(WFileName),False);
MyReg.Free;
end;

end.

[000080]


Чтение флажка "Run Minimized"

Решение 1

Кто-нибудь знает как из Delphi-приложении получить значение флажка "Run Minimized" (прятать программу при запуске), размещенного в Группе Запуска в Windows 3.1 или 3.11? Я не знаю как из своего приложения проверить этот флажок и запустить приложение с соответствующим состоянием главного окна. Я хотел бы предоставить пользователю право самому определять начальное состояние окна, поскольку мое приложение выполняет чисто технические задачи и не требует частого обращения. В то же время во время первого запуска приложение должно быть развернуто, поскольку необходимо выставить первоначальные параметры. Это кажется простым, но я не знаю путей решения этой проблемы. Буду благодарен за любую предоставленную информацию.

Привет!

Используй модуль WinProcs и после создания формы добавь вызов ShowWindow.

Ты можешь использовать глобальные переменные HInstance, HPrevInst, CmdShow и CmdLine.

program Project1;

uses
WinProcs, {*** используем WinProcs}
Forms,
Unit1 in 'UNIT1.PAS' {Form1};

{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
ShowWindow(Form1.handle, CmdShow);
Application.Run;
end.

Решение 2

Вот еще один пример, источник информации:

Rubenking, Neil (1996). _Delphi Programming Problem Solver_. Foster City, CA: IDG Books. ISBN:1-56884-795-5.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
ShowHow : word ;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
SUI : TStartupInfo ;
begin
if CmdShow = SW_SHOWDEFAULT then
begin
GetStartupInfo( SUI ) ;
ShowHow := SUI.wShowWindow ;
end
else
ShowHow := CmdShow ;

if ShowHow = SW_SHOWMAXIMIZED then
WindowState := wsMaximized ;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
case ShowHow of
SW_SHOWMINIMIZED,
SW_MINIMIZE,
SW_SHOWMINNOACTIVE :
Application.Minimize ;
end ;
end;

end.

Решение 3

Это работает с NT 4 и Delphi 2.01. Все очень просто: Сделайте примерно так:

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Form1.Show;
Application.Minimize;
Application.Run;
end.

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

Решение 4

Когда в Program Manager я выбираю опцию "Run Minimized", чтобы заставить мое Delphi приложение стартовать в свернутом состоянии, то, похоже, мое приложение просто игнорирует сей флаг и запускается в нормальном режиме. Почему так и как это исправить?

Объект Delphi Application создает скрытое "application window," и это окно, а не ваша главная форма, отдает команду на показ приложения в свернутом состоянии. Для того, чтобы это обойти, создайте примерно такой обработчик события главной формы OnCreate:

procedure TForm1.FormCreate(Sender: TObject);
{$IFDEF WIN32}           { Delphi 2-X.0 (32-бит) }
var
MyInfo: TStartUpInfo;
{$ENDIF}
begin
{$IFDEF WIN32}           { Delphi 2-X.0 (32-бит) }
GetStartUpInfo(MyInfo);
ShowWindow(Handle, MyInfo.wShowWindow);
{$ENDIF}
{$IFDEF WINDOWS}         { Delphi 1.0 (16-бит) }
ShowWindow(Handle, cmdShow);
{$ENDIF}
end;

Другими словами, для 16-бит достаточно флага cmdShow в ShowWindow. Для 32-бит необходимо получить "StartUp"-информацию вызовом процедуры GetStartUpInfo, которая заполняет запись TStartUpInfo, и затем передать TStartUpInfo.wShowWindow в ShowWindow.

[000270]


Drag & Drop c Win95 Explorer I

Вот что я почерпнул из эхоконференций:

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
ComCtrls;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
PROCEDURE FileIsDropped ( VAR Msg : TMessage ) ; Message WM_DropFiles ;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
shellapi;
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle,True ) ;
end;

PROCEDURE TForm1.FileIsDropped ( VAR Msg : TMessage ) ;
VAR
hDrop : THandle ;
fName : ARRAY[0..254] OF CHAR ;
NumberOfFiles : INTEGER ;
fCounter : INTEGER ;
Names : STRING ;
BEGIN
hDrop := Msg.WParam ;
NumberOfFiles := DragQueryFile(hDrop,-1,fName,254);
Names := '' ;
FOR fCounter := 1 TO NumberOfFiles DO BEGIN
DragQueryFile(hDrop,fCounter,fName,254);
// Здесь вы получаете один к одному имя вашего файла
Names := Names + #13#10 + fName ;
END ;

ShowMessage('Бросаем '+IntToStr(NumberOfFiles) + ' файла(ов) : ' + Names );
DragFinish ( hDrop);
END ;

end.

[000089]


Drag & Drop c Win95 Explorer II

Прислал Aleksey msalex@tomcat.ru:

{Так можно заставить окно принимать файлы, перетаскиваемые из проводника}
{ОБЯЗАТЕЛЬНО ПОМЕСТИТЕ В СЕКЦИЮ PRIVATE СТРОКИ
procedure CreateParams(var Params: TCreateParams); override;
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
и не забудьте - ShellAPI поместить в uses}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited
CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES; {сделаем окно способным принимать файлы}
end;

procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
var
aFile: array [0..255] of Char;
//FilesCount : Integer;
begin
inherited;
// FilesCount := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0); {так можно узнать сколько файлов перетягивается}
begin
{здесь можно поставить цикл открытия всех перетаскиваемых файлов
for N := 0 to FilesCount - 1 do DragQueryFile(Message.drop, N, aFile, 256);
а в данном случае открывается только первый файл в списке}
DragQueryFile(Message.drop, 0, aFile, 256);
Memo1.Lines.LoadFromFile(aFile);
end;
DragFinish(Message.Drop);
end;

procedure TForm1.FormCreate(Sender: TObject); {Form1.OnCreate}
begin
DragAcceptFiles(Handle, True); {сделаем окно неравнодушным к пролетающим над ним файлам}
end;
[000117]


Одной строкой

ListBox и Drag&Drop

Расположите на форме ListBox и Label. Установите свойство списка dragmode на dmAutomatic. Поместите следующую строку в обработчике события OnDragOver:

Label1.Caption := IntToStr(Y);

Теперь запустите программу и тащите какой-либо элемент в направлении правого верхнего угла до верхней границы списка. Обратите внимание как изменяется координата Y - уменьшаясь, она принимает значение -1, когда курсор выходит за верхнюю границу. (Примечание - только что попробовал это в Delphi 5 - нижнее значение показало -2).

Теперь осталось только определить, около какого элемента списка находится курсор мыши, для чего используйте ItemAtPos. [000344]


Преобразование координат

Поверьте, достаточно просто преобразовать X,Y координаты, передаваемые в параметрах событий OnDragOver и OnDragDrop, в координаты формы.

Работайте со свойствами Left и Top компонента, над которым перемещается курсор. Приведу простой пример. Поместите на форму компонент Memo и присвойте свойству Align значение alTop. Поместите на форму панель, также присвойсте свойству Align значение alTop и задайте небольшое значение свойству Height, скажем 6 или 7 пикселей. Установите DragMode на dmAutomatica и DragCursor на crVSplit. Поместите другой Memo-компонент и установите Align на alClient. Одновременно выберите оба Memo-компонента, панель и создайте общий обработчик события OnDragOver как показано ниже:

procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
IF Source = Panel1 THEN
WITH Sender AS TControl DO
BEGIN
Accept := True;
Memo1.Height := Y + Top;
END
ELSE Accept := False;
end;

Теперь попробуйте это!

- Neil
[000355]


Одной строкой

Прием файлов из Program Manager I

Смотри функцию Windows API DragAcceptFiles. Вы должны это вызвать, чтобы зарегистрировать вашу программу в качестве "приемного пункта" перетаскиваемых файлов. Далее в вашем приложении вы должны реагировать на сообщение WM_DROPFILES, возникающее при операции drag/drop из File Manager. [000413]


Delphi 1

Прием файлов из Program Manager II

Для осуществления функции drag/drop из File Manager, вы должны "зарегистрировать" дескриптор принимаемой формы (свойство Handle) Windows API функцией

DragAcceptFiles(Handle, True);

После этого вы сможете получать сообщения WM_DROPFILES при перетаскивании файлов из File Manager в вашу форму. Для "отключения" этой характеристики необходимо вторично вызвать ту же API функцию, но со вторым параметром равным False.

Для получения имен перетаскиваемых файлов необходимо воспользоваться Windows функцией DragQueryFile, для получения информации при окончании операции Drag/Drop воспользуйтесь функцией DragFinish. DragQueryPt подскажет вам в каком месте формы былы "брошены" перетаскиваемые файлы.

Вам необходимо принимать файлы даже при свернутой форме? Для этого нужно дополнительно создать обработчик события OnMessage объекта Application. Нижеприведенный пример предполагает, что на форме имеется компонент ListBox, свойство Align которого установлено в alClient:

...
{ Private declarations }
procedure WMDropFiles(VAR Msg: TWMDropFiles);
message WM_DROPFILES;
procedure AppOnMessage(VAR Msg: TMsg;
VAR Handled : Boolean);
...
implementation
USES ShellApi;
...
procedure TForm1.WMDropFiles(VAR Msg: TWMDropFiles);
VAR
N : Word;
buffer : ARRAY[0..80] OF Char;
BEGIN
WITH Msg DO
BEGIN
FOR N := 0 TO DragQueryFile(Drop, $FFFF, buffer, 80)-1 DO
BEGIN
DragQueryFile(Drop, N, Buffer, 80);
ListBox1.Items.Add(StrPas(Buffer));
END;
DragFinish(Drop);
END;

END;

procedure TForm1.AppOnMessage(VAR Msg: TMsg;
VAR Handled : Boolean);
VAR WMD : TWMDropFiles;
BEGIN
IF Msg.message = WM_DROPFILES then
BEGIN
MessageBeep(0);
WMD.Msg    := Msg.message;
WMD.Drop   := Msg.wParam;
WMD.Unused := Msg.lParam;
WMD.Result := 0;
WMDropFiles(WMD);
Handled := TRUE;
END;

END;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle, True);
DragAcceptFiles(Application.Handle, True);
Application.OnMessage := AppOnMessage;
end;

[000466]


Delphi 1

Перетаскивание элементов управления c рамкой контура

...как перетаскивать элементы управления с контурной рамкой по их форме, "приклеенной" к курсору? Решение, найденное вами, работать не будет, поскольку таскаемая рамка не обязательно может находиться в пределах области компонента (а вы отрисовываете ее только на компоненте).

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

Начните со свеженькой формы. Бросьте на нее компонент Notebook и установите его свойство Align в alClient. Разработайте форму на первой странице компонента Notebook. Создайте вторую страницу в Notebook, поместите туда Paintbox и установите его свойство Align в alClient. Далее добавьте нижеследующие строчки в секцию Private вашей формы:

Img : TBitmap;
DragX, DragY, DragW, DragH, XOff, YOff : Integer;

В обработчике формы OnCreate:

Img := TBitmap.Create;

В общем, для всех перетаскиваемых компонентов, обработчике события OnMouseDown:

IF NOT (ssShift IN Shift) THEN Exit;
Img := GetFormImage;
Notebook1.PageIndex := 1;
WITH Sender AS TControl DO
BEGIN
DragW := Width;
DragH := Height;
XOff:= X;
YOff := Y;
BeginDrag(True);
END;

В общем, для всех перетаскиваемых компонентов, обработчике события EndDrag:

Notebook1.PageIndex := 0;
WITH Sender AS Tcontrol DO
BEGIN
Left := X-Xoff;
Top := Y-YOff;
END;

Поместите следующую строку в обработчик события OnPaint компонента PaintBox:

PaintBox1.Canvas.Draw(0, 0, Img);

И наконец, если вам еще это не надоело, поместите следующую строчку в обработчик OnDragOver компонента PaintBox:

IF (X=DragX) AND (Y=DragY) THEN Exit;
WITH PaintBox1.Canvas DO
BEGIN
DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
DragX := X; DragY := Y;
DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
END;

ФУ!! Но это работает! Я не хотел убирать в компонентах возможность перетаскивания их мышью обычным способом, поэтому для включения дополнительной характеристики необходимо при старте держать нажатой клавишу Shift. Попробуйте это!

- NEil

Я пытаюсь "потаскать" TPanel, используемую в качестве ToolBar и всегда почему-то получаю иконку с перечеркнутым кругом. Я понимаю, что это означает невозможность перетаскивания. К сожалению, в документации я ничего не нашел как решить эту проблему. Я пробовал и ручные, и автоматические настройки (DragMode = dmManual/dmAutomatic - В.О.), но все без толку.

Иногда я вообще не могу "оторвать" TPanel!

Начнем с самого начала. Причина того, что вы получаете курсор "crNoDrop" в том, что под курсором элемент управления не готов принять перетаскиваемый компонент. Чтобы исправить эту ситуацию, дважды щелкните (в Инспекторе Объектов) на событии формы или компонента OnDragOver и установите параметр Accept в, например так:

procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := true ;
end;

Благодарю за пример создания прямоугольника при перетаскивании. Ваши инструкции помогли мне первое время и я легко интегрировал ваш код в мое приложение. Но если вы не возражаете, я хотел бы получить другой небольшой совет .... есть ли возможность во время операции перетаскивания (PaintBox1DragOver) работать с элементами управления, находящимимя под PainBox с тем, чтобы они также изменяли курсор и также могли бы принимать перетаскиваемый элемент? Когда перетаскиваемый элемент выдает сообщение EndDrag, параметр Target должен быть PaintBox (логически).

Можно как-то определить, с каким конкретно элементом управления, расположенным под PainBox, взаимодействует в данный момент перетаскиваемый элемент (для его акцептования)? Я опять что-то упустил, но я не знаю как это сделать.

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

FOR N := 0 TO ComponentCount-1 DO
IF COmponents[N] IS TButton THEN
IF IntersectRect(DummyRect, TControl(Components[N]).BoundsRect,
(Bounds(X-XOff, Y-YOff, DragW, DragH)) >0 THEN
Accept := False;

В этом случае курсор будет изменяться на перечеркнутый кружок при пересечении перетаскиваемым элементом границы интересующей вас кнопки. Вы должны сделать аналогичную логику или в обработчике EndDrag или OnDragDrop компонента PainBox. [000436]


Delphi 1

Drag & Drop между двумя компонентами ListBox

Вот пересмотренный OnDragDrop, использующий source (источник) и sender (передатчик) вместо DstList и SrcList. Теперь, если вы установили SrcList и DstList для использования тех же методов OnDragOver и OnDragDrop и создали обработчик события OnDragDrop, то для операции Drag and Drop вы можете использовать оба решения.

procedure TDualListDlg.DstListDragDrop(Sender, Source: TObject; X,
Y: Integer);
var
droppedOnIndex: integer;
anItem:        integer;
numberOfItems: integer;
begin
if (Sender is TListbox) and (Source is TListBox) then
begin
droppedOnIndex := TListBox(Sender).ItemAtPos(Point(X,Y),false);
numberOfItems := TListBox(Source).SelCount;
anItem := 0;

while numberOfItems > 0 do
begin
if TListBox(Source).Selected[anItem] = true then
begin
TListBox(Sender).Items.Insert(droppedOnIndex,TListBox(Source).Items[anItem]);
TListBox(Source).Items.Delete(anItem);
TListBox(Source).Update;
TListBox(Sender).Update;
numberOfItems := numberOfItems - 1;
end
else
anItem := anItem + 1;
end;
end;
end;

Для того, чтобы предотвратить операцию Drag and Drop с одним и тем же компонентом, используйте следующий код в обработчике события OnDragOver:

if (Sender is TListBox) and (Source is TListBox) then
begin
if TListBox(Sender).Name = TListBox(Source).Name then
Accept := False
else
Accept := true;
end

[000445]


Delphi 1

Drag & Drop TImage

Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.

procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
WITH Source AS TImage DO
BEGIN
Left := X;
Top := Y;
END;
end;

procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source IS TImage;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
WITH TImage.Create(Self) DO
BEGIN
Parent := Panel1;
AutoSize := True;
Picture.LoadFromFile('D:\DELPHI\IMAGES\CHIP.BMP');
DragMode := dmAutomatic;
OnDragOver := Panel1DragOver;
OnDragDrop := Panel1DragDrop;
END;
end;

[000651]


Delphi 1

Drag&Drop с минимизированным приложением

В ситуации, когда ваше приложение минимизировано, необходимо понимать, что окно главной формы НЕ работает. Фактически, если вы проверяете окно главной формы, и обнаруживаете, что оно имеет прежний размер, не удивляйтесь, оно просто невидимо. Иконка минимизированного Delphi-приложения принадлежит объекту Application, чей дескриптор окна - Application.Handle.

Вот некоторый код из моей программы, который с помощью компонента CheckBox проверяет возможность принятия перетаскиваемых файлов минимизированным приложением:

procedure TForm1.WMDropFiles(VAR Msg: TWMDropFiles);
{Вызывается только если TApplication НЕ получает drag/drop}
BEGIN
RecordDragDrop(Msg.Drop, False); {внутренняя функция}
Msg.Result := 0;
END;

procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: Boolean);
{когда активно, получаем сообщения WM_DROPFILES, посылаемые
форме ИЛИ минимизированному приложению}
BEGIN
IF Msg.message = WM_DROPFILES THEN
BEGIN
RecordDragDrop(Msg.wParam, Msg.hWnd = Application.Handle);
Handled := True;
END;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle, True);
DragAcceptFiles(Application.Handle, False);
Application.OnMessage := NIL;
END;
end;

OK? Первоначально вызов DragAcceptFiles работает с дескриптором главной формы...

- Neil J. Rubenking [000754]


Как приложению воспользоваться своими шрифтами? Без помощи пользователя

Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.

Ниже приведен код для Delphi 1, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с 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}

Дополнение

Nomadic предлагает следующее решение:

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно следующим образом:

{$IFDEF WIN32}
AddFontResource( PChar( my_font_PathName { AnsiString } ) );
{$ELSE}
var
ss : array [ 0..255 ] of Char;

AddFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

Убрать его по окончании работы:

{$IFDEF WIN32}
RemoveFontResource ( PChar(my_font_PathName) );
{$ELSE}
RemoveFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 )

При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName: string ( не string[nn] для D2 и выше) - содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным. В любом случае я это не проверял. [000090]


Включение шрифта как ресурс в *.EXE

Включение шрифта в ваш EXE:

  1. Используйте ваш любимый текстовый редактор, создайте *.rc файл, описывающий шрифт:
    MY_FONT ANYOL1 "Bauhs93.ttf"

    Первые два параметра могут быть любыми. Они будут использоваться в программе позже.

  2. Затем для создания *.res файла используйте компилятор командной строки BRCC32.EXE, поставляемый с Delphi. Если ваш файл на этапе 1 был назван MyFont.rc, командная строка в сеансе DOS должна выглядеть так:
    BRCC32 MyFont

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

  3. В вашей программе добавьте директиву компилятора, чтобы включить вновь созданный файл:
    {$R MyFont.res}

    Правильным будет разместить его в секции реализации после строчки {$R *.DFM}.

  4. Добавьте процедуру создания файла из ресурса, делающим шрифт доступным для использования. Пример:
    procedure TForm1.FormCreate(Sender: TObject);
    var
    Res : TResourceStream;
    begin
    Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1'));
    Res.SavetoFile('Bauhs93.ttf');
    Res.Free;
    AddFontResource(PChar('Bauhs93.ttf'));
    SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
    end;

  5. Теперь вы можете использовать данный шрифт в своем приложении:
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Button1.Font.Name := 'Bauhaus 93';
    end;

Предостережения:

Приведенный пример не предусматривает никакой проверки и защиты от возможных ошибок.

Обратите внимание - имя файла НЕ такое же, как имя шрифта. Это допускает, что вы знаете имя шрифта и имя его ttf-файла. Вы можете определить это, дважды щелкнув на файле в окне Проводника.

Я рекомендую устанавливать файл шрифта в папку C:\WINDOWS\FONTS. Его легче отыскать потом именно там.

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

procedure TForm1.FormDestroy(Sender: TObject);
begin
RemoveFontResource(PChar("Bauhs93.ttf"))
SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
end;

Для получения дополнительной справки по функциям AddFontResource и RemoveFontResource загляните в электронную справку по Win32. [000091]


Как определить, большие или маленькие шрифты используются в системе?

Попробуй это:

FUNCTION SmallFonts : BOOLEAN;
{возвращает TRUE если установлены маленькие шрифты и FALSE если большие }
VAR
DC : HDC; { используется для проверки количества доступных цветов }
BEGIN
DC := GetDC(0);
Result :=   (GetDeviceCaps(DC, LOGPIXELSX) = 96);
{ Если используются большие шрифты, LOGPIXELSX будет равен 120 }
ReleaseDC(0, DC);
END;

[000281]


Большие/Маленькие шрифты?

Когда мои программы работают на системах с установленными маленькими шрифтами, я получаю странный вид моей формы. К примеру, расположенные на форме компоненты 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.

[000282]


Переключение с 96DPI на 120DPI

Вы серьезно предлагаете мне, для того, чтобы получить профессиональный результат, разрабатывать свои формы в этом системном разрешении?

Нет, конечно нет. Масштабирование Delphi кажется работает не хуже, чем стандартный диалог масштабирования Windows. Правда, результат иногда получается просто безобразным. Я думаю, главная проблема здесь в размере шрифтов: когда вы переключаетесь с 96DPI на 120DPI, размеры шрифта изменяются. Но мне, правда, повезло: в моей 96DPI-форме я использовал шрифт размером 10 точек, а при 120DPI он превратился в 8-точечный. Итак, мои предложения:

  • Попробуйте использовать растровые шрифты, поскольку они масштабируются наиболее качественно
  • Используйте шрифты TrueType, которые вообще не имеют проблем масштабирования
[000320]


Размер масштабированного шрифта

При Scaling = False, Delphi не пытается изменить размер окна и элементов управления, использующих системные шрифты. Если элементы управления используют системный шрифт, размер текста не изменяется.

Вы можете попробовать заставить главное окно использовать определенный шрифт (используя свойство Font). Элементы управления должны получать этот шрифт автоматически (если вы не сбросили в False свойство ParentFont), после чего ваше приложение должно выглядеть одинаково при любом разрешении и с любым системным шрифтом.

Попробуйте использовать шрифт TrueType, скажем Arial вместо MS Sans Serif, но будьте внимательны, при этом приложением игнорируется смена пользователем маленких/больших шрифтов в Панели Управления.

Как известно, пользователю легче пользоваться диалогами с маленькими шрифтами, чем глядеть все время на большой текст. [000322]


Delphi 1

Проверка шрифта с фиксированной шириной

Посмотрите в библиотеке console.zip от Danny Thorpe -- он проверяет, является ли шрифт шрифтом с фиксированной шириной. Вот код, который делает это:

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;

Andy King. [000728]


Свойства шрифта Style/Color в виде строки

Как мне получить значение 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.

- Dennis Passmore [000850]


Delphi 2

PopupComponent и шрифты

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

Хитрость заключается в создании в вашей секции implementation следующего описания класса:

type
THack = class(TControl)
public
property Font;
end;

затем ваш код может выглядеть приблизительно так:

if Popup1.PopupControl is TControl then
if FontDialog1.Execute then
THack(Popup1.PopupControl).Font := FontDialog1.Font;

- Pat Ritchey [000965]


Центрирование информационного диалога (MessageDlg)

Используйте следующую процедуру:

unit kns;

{$R-}

interface

uses Forms, Dialogs;

{ Центрирование информационного диалога }
function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;

implementation

uses Consts;

{ Функция MessageDlg располагает диалог над центром активного окна }

function MessageDlgCtr(const Msg: string;  DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
begin
with CreateMessageDialog(Msg, DlgType, Buttons) do
try
HelpContext := HelpCtx;
Left := Screen.ActiveForm.Left + (Screen.ActiveForm.Width div 2) -
(Width div 2);
Top := Screen.ActiveForm.Top + (Screen.ActiveForm.Height div 2) -
(Height div 2);
Result := ShowModal;
finally
Free;
end;
end;

end.
[000104]


Вызов стандартного системного окна "О программе"

Прислал Aleksey msalex@tomcat.ru:

{процедура показывает стандартное виндусовское окно абаута}
{Не забудьте - ShellAPI поместить в uses}

procedure ShowAbout;
begin
ShellAbout(Form1.Handle,
'Напиши здесь название программы',
'Заяви здесь о своих авторских правах на программу' #13#10
'можно в две строки',
Application.Icon.Handle);
end;

Спасибо за замеченную неточность Andrew Balahonov. [000113]


MessageDlg в обработчике OnExit

Я пытаюсь использовать MessageDlg в обработчике OnExit компонента TEdit. При показе диалогового окна пользователь нажимает одну из кнопок, после чего, по идее, должно возникнуть событие OnEnter компонента, но оно не возникает! Если вызов диалога сопровождается комментарием, событие OnEnter инициализируется верно. В любом случае, событие OnExit завершает весь код.

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

PostMessage(Handle, WM_NEXTDLGCTL, 0, 0) ;
PostMessage(Handle, WM_NEXTDLGCTL, 1, 0) ;

OAmiry/Borland [000573]


Delphi 1

MessageDlg без Gliph

Как мне получить информационное окошко c 3D-стилем и простыми кнопками (без Glyph), не особо изголяясь в программировании?

Просто добавьте следующую строчку в ваш код диалогового окошка:

MsgDlgGlyphs := false;

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

Steve Samuelson [000741]


Delphi 1

Избавление от системного окна с ошибкой

Имеется функция Windows API, преобразующя уродливые Windows-окна, информирующие об ошибках в в привычные исключения Delphi, что, по крайней мере, более эстетично и полезно (поскольку в этом случае ошибка может быть перехвачена и обработана вашей программой).

SetErrorMode(SEM_FAILCRITICALERRORS);

Это все! Эта функция сообщает Windows о том, что вызвавшая ошибку программа будет сама обрабатывать критические ошибки.

- Neil J. Rubenking [000768]


Размер диалогового окна

Давайте начнем с Microsoft Windows User Interface Guidelines (Руководящие Принципы Построения Интерфейса Пользователя Microsoft Windows) и допустим, что мы создаем диалоговое окно, содержащее компонент TMemo, занимающий большую часть площади формы и кнопки OK и Cancel, размещенные в ее нижней части.

Несколько примечаний из "Принципов":

  1. Диалоговые окна должны быть основаны на базовых диалоговых модулях, dialog base units (DBU), которые создаются с учетом размера шрифта и разрешения экрана.
  2. Диалоговые окна должны быть созданы, по возможности, на основе одного из нескольких стандартных размеров. Для нашего окна мы используем размер 212x188 DBU.
  3. Все элементы управления должны распологаться как минимум на расстоянии 7 DBU от края окна.
  4. Все элементы управления должны иметь между друг другом зазор размером минимум 4 DBU.
  5. Кнопки должны иметь высоту 14 DBU. (Про ширину кнопок "принципы" умалчивают; в обычном случая я использую кнопки шириной 40 DBU.)
Вот необходимая для создания формы и элементов управления информация, которую мы можем получить во время выполнения приложения:

procedure TMyForm.FormCreate(Sender: TObject);
var
BaseUnit, Margin, Spacing, BtnW, BtnH: Integer;
begin
BaseUnit := Canvas.TextHeight('0');  { 1 BaseUnit = 8 DBU определениям }
Width := (212 * BaseUnit) div 8;
Height := (188 * BaseUnit) div 8;
Margin := (7 * BaseUnit) div 8 - GetSystemMetrics(SM_CXFIXEDFRAME);
Spacing := (4 * BaseUnit) div 8;
BtnW := (40 * BaseUnit) div 8;
BtnH := (14 * BaseUnit) div 8;
Memo1.SetBounds(Margin, Margin, ClientWidth - 2 * Margin, ClientHeight -
2 * Margin - Spacing - BtnH);
OkButton.SetBounds(ClientWidth - Margin - Spacing - 2 * BtnW, ClientHeight -
Margin - BtnH, BtnW, BtnH);
CancelButton.SetBounds(ClientWidth - Margin - BtnW, ClientHeight - Margin -
BtnH, BtnW, BtnH);
end;

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

- Steve Schafer [000976]


Снимок DESKTOP в form.canvas

Попробуйте это:

procedure TScrnFrm.GrabScreen;
var

DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;

begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;

DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);

ScrnForm.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);

ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;

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

[000119]


Как получить снимок экрана (типа screen-capture программ)?

Решение 1

Используйте стандартный Windows API:

используйте hWnd := GetDesktopWindow для получения дескриптора 'рабочего стола';
используйте hDC := GetDC (hWnd) для получения HDC (дескриптора контекста экрана) ;
и не забывайте освобождать (уничтожать дескриптор) hDC после выполнения задачи.

Используя TCanvas.Handle в качестве HDC, можно при помощи WinAPI реализовать функции рисования, или, если это возможно, можно присвоить HDC свойству Handle непосредственно при создании TCanvas.

Решение 2

В D1 (по идее должно работать и в D2) попробуйте это:

Разместите на форме TPaintBox и TButton.

procedure TForm1.Button1Click(Sender: TObject);

var
DeskTop : TCanvas ;

begin
DeskTop := TCanvas.Create ;
try
with DeskTop do
Handle := GetWindowDC (GetDesktopWindow) ;

with PaintBox1.Canvas do
CopyRect (Rect (0, 0, 200, 200),
DeskTop,
Rect (0, 0, 200, 200))

finally
DeskTop.Free

end
end;

Это скопирует верхнюю левую область рабочего стола в верхнюю левую область вашего TPaintBox. [000121]


Shell_NotifyIcon

У меня есть несколько вопросов по функции Shell_NotifyIcon:
  • Как добавить иконку в системную область панели задач?
  • Как изменить иконку?
  • Как удалить иконку?
  • И я не могу получать сообщения от иконки!!

Чтобы получать сообщения, вы должны добавить флаг NIF_MESSAGE в вашу notify-структуру и записать то сообщение, которое вы хотите послать. Вот код, который я использую:

procedure TMainForm.UpdateTaskBar;            // обновление области системных иконок win95 var
NotifyData: TNotifyIconData;

begin
With NotifyData do                                          // устанавливаем структуру данных
begin
cbSize           := SizeOf(TNotifyIconData);
Wnd              := MyForm.Handle;
uID              := 0;
uFlags           := NIF_ICON or NIF_MESSAGE or NIF_TIP;   // ... установки, которые необходимо изменить ...
uCallbackMessage := WM_MY_MESSAGE;                        // ... возвращаемое нам сообщение ...
hIcon            := hMyIcon;
szTip            := 'Текст всплывающей подсказки';        // ... и соответствующий текст
end;
Shell_NotifyIcon(dwMessage, @NotifyData);                   // теперь производим обновление
end;

WM_MYMESSAGE - определенное пользователем сообщение. Обычно определяется как:

const
WM_MYMESSAGE = WM_USER + <какой-то номер, может быть нулем>;

[000273]


Как спрятать панель задач в Windows 95?

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

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

  1. Сначала объявим переменную типа HWND, в которой будем хранить дескриптор окна панели задач Windows 95:

    TForm1 = class(TForm)
    ...
    private
    hTaskBar: HWND;
    ...
    end;

  2. В обработчике события OnCreate() главной формы напишем код подобно этому:

    hTaskBar := FindWindow('Shell_TrayWnd', nil);
    ShowWindow(hTaskBar, SW_HIDE);

  3. И, наконец, в обработчике события главной формы OnDestroy() необходимо вставить следующую строчку:

    ShowWindow(hTaskBar, SW_SHOW);

Другое решение

PROCEDURE HideWin95TaskBar;
VAR
WindowHandle: hWnd;
BEGIN
{Скрытие панели задач Windows 95}
WindowHandle := FindWindow('Shell_TrayWnd', '');
IF   WindowHandle <> 0
THEN ShowWindow(WindowHandle, SW_HIDE)
END {HideWin95TaskBar};

PROCEDURE ShowWin95TaskBar;
VAR
WindowHandle:  hWnd;
BEGIN
{Восстанавливаем видимость панели задач Windows 95}
WindowHandle := FindWindow('Shell_TrayWnd', '');
IF   WindowHandle <> 0
THEN ShowWindow(WindowHandle, SW_RESTORE)
END {ShowWin95TaskBar};

[000276]


Как программно заменить обои на рабочем столе? I

Решение 1

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

unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Bitmap: TBitmap;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;

procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do begin
X := 0;
while X < Width do begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;

end.

Решение 1

Кто-нибудь знает как можно во время выполнения программы заменить обои рабочего стола на определенное изображение?

procedure ChangeWallpaper(bitmap: string);       {имя файла с изображением: *.bmp}

var pBitmap : pchar;

begin
bitmap:=bitmap+#0;
pBitmap:=@bitmap[1];
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE);
end;

Можно ли сохранить сделанные изменения в INI-файле для последующих сессий?

  1. добавьте inifiles в список используемых модулей.
  2. создайте inifile в текстовом редакторе как показано ниже:

    [LastUsedBitmap]
    LUBitmap= c:\mybitmap.bmp

  3. используйте примерно такую процедуру (исходим из предположения, что inifile подобно вышеупомянутому с именем c:\Bitmap.ini):

    procedure WriteToIniFile(bitmap : string);

    var MyIniFile : TInifile;

    begin
    MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' );
    MyIniFile.WriteString( 'LastUsedBitmap', 'LUBitmap', bitmap);
    MyIniFile.Free;
    end;

    procedure ReadFromIniFile(var bitmap: string);

    var MyIniFile : TInifile;

    begin
    MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' );
    bitmap:= MyIniFile.ReadString('LastUsedBitmap', 'LUBitmap');
    MyIniFile.Free;
    end;

    [000279]


Delphi 1

Как программно заменить обои на рабочем столе? II

Для этого необходимо заставить Windows перечитать файл Win.ini с новым параметром обоев рабочего стола. Это возможно с помощью функции Windows API SystemParametersInfo, примерно так:

SystemParametersInfo(spi_SetDeskWallPaper,0,Addr(BmpFileName),spif_UpdateIniFile + spif_SendWinIniChange);

где BmpFileName - PChar, содержащий имя файла с изображением. Обратите внимание на четвертый параметр, spif_UpdateIniFile. Он записывает изменения в Win.ini. Параметр spif_SendWinIniChange посылает всем окнам сообщение о факте изменения Win.ini. [000453]


Определение имени Группы Запуска (StartUp)

В различный языковых версих Windows папка 'StartUp' звучит по-разному. Как мне определить ее текущее имя??

Вам следует обратиться к регистрам:

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Start Menu

Надеюсь это то, что вам нужно. [000284]


Кнопки в панели задач Win95

Может ли кто-нибудь поделиться информацией, компонентом или еще чем, позволяющим в Delphi 2 или 3 создать кнопку в панели задач так, как это делает PowerDesk 2.0 Toolbar.

Да запросто!

// Это необходимо объявить в секции public в верхней части вашего pas-файла
procedure TForm1.IconCallBackMessage( var Mess : TMessage ); message WM_USER
+ 100;

procedure TForm1.FormCreate(Sender: TObject);
var
nid : TNotifyIconData;
begin
with nid do
begin
cbSize := SizeOf( TNotifyIconData );
Wnd := Form1.Handle;
uID := 1;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallbackMessage := WM_USER + 100;
hIcon := Application.Icon.Handle;
szTip := 'Текст всплывающей подсказки';
end;
Shell_NotifyIcon( NIM_ADD, @nid );
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
nid : TNotifyIconData;
begin
with nid do
begin
cbSize := SizeOf( TNotifyIconData );
Wnd := Form1.Handle;
uID := 1;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallbackMessage := WM_USER + 100;
hIcon := Application.Icon.Handle;
szTip := 'Текст всплывающей подсказки';
// Все, что указано выше, не является обязательным
end;
Shell_NotifyIcon( NIM_DELETE, @nid );
end;

procedure TForm1.IconCallBackMessage( var Mess : TMessage );
var
sEventLog : String;
begin
case Mess.lParam of
// Сделайте здесь все что вы хотите. Например, вызов контекстного меню при нажатии правой кнопки мыши.
WM_LBUTTONDBLCLK  : sEventLog := 'Двойной щелчок левой кнопкой';
WM_LBUTTONDOWN    : sEventLog := 'Нажатие левой кнопки мыши';
WM_LBUTTONUP      : sEventLog := 'Отжатие левой кнопки мыши';
WM_MBUTTONDBLCLK  : sEventLog := 'Двойной щелчок мышью';
WM_MBUTTONDOWN    : sEventLog := 'Нажатие кнопки мыши';
WM_MBUTTONUP      : sEventLog := 'Отжатие кнопки мыши';
WM_MOUSEMOVE      : sEventLog := 'перемещение мыши';
WM_MOUSEWHEEL     : sEventLog := 'Вращение колесика мыши';
WM_RBUTTONDBLCLK  : sEventLog := 'Двойной щелчок правой кнопкой';
WM_RBUTTONDOWN    : sEventLog := 'Нажатие правой кнопки мыши';
WM_RBUTTONUP      : sEventLog := 'Отжатие правой кнопки мыши';
end;
end;

[000289]


Скрытие кнопки "Пуск"

Используйте модуль proc. Для скрытия стартовой кнопки используйте следующий код:

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) = 'BUTTON'
then begin
// IsWindowVisible(Child)
startbutton_handle:=child;
If Visi
then ShowWindow(Child, 1)
else ShowWindow(Child, 0);
end;
End;
Child := GetWindow(Child, GW_HWNDNEXT);
End;
End;

[000292]


Delphi 1

Количество цветов в системе

Мне необходимо узнать как сконфигурирована система: для работы с 16 или 256 цветами.

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

1 shl GetDeviceCaps( Canvas.Handle, BITSPIXEL )

- Mike Scott [000877]


Delphi 1

Delphi 1 и Панель Задач Windows 95

Под win95 в EXE-файле, скомпилированном в Delphi 1, каждая форма, имеющая диалоговый стиль, имеет на Панели Задач свою кнопку. Например в ситуации, когда имеется главная форма и форма с фокусом, пользователь может нажать кнопку главной формы и не увидеть форму, активную в данный момент, вследствие чего он может подумать о том, что приложение "зависло". Такое же поведение наблюдается если активна форма, не имеющая диалогового стиля, а пользователь нажимает на Панели Задач кнопку главной формы.

Скрытому окну Delphi-приложения необходим стиль WS_CAPTION, поэтому вам необходимо его задать только в модуле Forms или в обработчике события формы OnCreate:

SetWindowLong(Application.Handle,GWL_STYLE, WS_CAPTION or      GetWindowLong(Application.Handle,GWL_STYLE))

Это также причина того, почему это работает в Delphi 2 (здесь стиль устанавливается в Forms)!

- Nils Seidel [000988]


Обзор сети (типа Network Neighborhood - Сетевое Окружение)

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

{
Сетевая утилита. Аналогична функции NetWork-
Neighborhood - Сетевое Окружение.
}

unit netres_main_unit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
ComCtrls, StdCtrls, Buttons, Menus, ExtCtrls;

type
TfrmMain = class(TForm)
tvResources: TTreeView;
btnOK: TBitBtn;
btnClose: TBitBtn;
Label1: TLabel;
barBottom: TStatusBar;
popResources: TPopupMenu;
mniExpandAll: TMenuItem;
mniCollapseAll: TMenuItem;
mniSaveToFile: TMenuItem;
mniLoadFromFile: TMenuItem;
grpListType: TRadioGroup;
grpResourceType: TRadioGroup;
dlgOpen: TOpenDialog;
dlgSave: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure mniExpandAllClick(Sender: TObject);
procedure mniCollapseAllClick(Sender: TObject);
procedure mniSaveToFileClick(Sender: TObject);
procedure mniLoadFromFileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
private
ListType, ResourceType: DWORD;
procedure ShowHint(Sender: TObject);
procedure DoEnumeration;
procedure DoEnumerationContainer(NetResContainer: TNetResource);
procedure AddContainer(NetRes: TNetResource);
procedure AddShare(TopContainerIndex: Integer; NetRes:
TNetResource);
procedure AddShareString(TopContainerIndex: Integer; ItemName:
String);
procedure AddConnection(NetRes: TNetResource);
public
{ Public declarations }
end;

var
frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.ShowHint(Sender: TObject);
begin
barBottom.Panels.Items[0].Text:=Application.Hint;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
Application.OnHint:=ShowHint;
barBottom.Panels.Items[0].Text:='';
end;

procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
Close;
end;

{
Перечисляем все сетевые ресурсы:
}
procedure TfrmMain.DoEnumeration;
var
NetRes: Array[0..2] of TNetResource;
Loop: Integer;
r, hEnum, EntryCount, NetResLen: DWORD;
begin
case grpListType.ItemIndex of
{ Подключенные ресурсы: }
1: ListType:=RESOURCE_CONNECTED;
{ Возобновляемые ресурсы: }
2: ListType:=RESOURCE_REMEMBERED;
{ Глобальные: }
else ListType:=RESOURCE_GLOBALNET;
end;

case grpResourceType.ItemIndex of
{ Дисковые ресурсы: }
1: ResourceType:=RESOURCETYPE_DISK;
{ Принтерные ресурсы: }
2: ResourceType:=RESOURCETYPE_PRINT;
{ Все: }
else ResourceType:=RESOURCETYPE_ANY;
end;

Screen.Cursor:=crHourGlass;

try
{ Удаляем любые старые элементы из дерева: }
for Loop:=tvResources.Items.Count-1 downto 0 do
tvResources.Items[Loop].Delete;
except
end;

{ Начинаем перечисление: }
r:=WNetOpenEnum(ListType,ResourceType,0,nil,hEnum);
if r<>NO_ERROR then
begin
if r=ERROR_EXTENDED_ERROR then
MessageDlg('Невозможно сделать обзор сети.'+#13+
'Произошла сетевая ошибка.',mtError,[mbOK],0)
else
MessageDlg('Невозможно сделать обзор сети.',
mtError,[mbOK],0);
Exit;
end;

try
{ Мы получили правильный дескриптор перечисления; опрашиваем ресурсы: }
while (1=1) do
begin
EntryCount:=1;
NetResLen:=SizeOf(NetRes);
r:=WNetEnumResource(hEnum,EntryCount,@NetRes,NetResLen);
case r of
0: begin
{ Это контейнер, организуем итерацию: }
if NetRes[0].dwUsage=RESOURCEUSAGE_CONTAINER then
DoEnumerationContainer(NetRes[0])
else
{ Здесь получаем подключенные и возобновляемые ресурсы: }
if ListType in [RESOURCE_REMEMBERED,RESOURCE_CONNECTED]
then
AddConnection(NetRes[0]);
end;

{ Получены все ресурсы: }
ERROR_NO_MORE_ITEMS: Break;
{ Другие ошибки: }
else begin
MessageDlg('Ошибка опроса ресурсов.',mtError,[mbOK],0);
Break;
end;
end;
end;

finally
Screen.Cursor:=crDefault;
{ Закрываем дескриптор перечисления: }
WNetCloseEnum(hEnum);
end;
end;

{
Перечисление заданного контейнера:
Данная функция обычно вызывается рекурсивно.
}
procedure TfrmMain.DoEnumerationContainer(NetResContainer:
TNetResource);
var
NetRes: Array[0..10] of TNetResource;
TopContainerIndex: Integer;
r, hEnum, EntryCount, NetResLen: DWORD;
begin
{ Добавляем имя контейнера к найденным сетевым ресурсам: }
AddContainer(NetResContainer);
{ Делаем этот элемент текущим корневым уровнем: }
TopContainerIndex:=tvResources.Items.Count-1;
{ Начинаем перечисление: }
if ListType=RESOURCE_GLOBALNET then
{ Перечисляем глобальные объекты сети: }
r:=WNetOpenEnum(ListType,ResourceType,RESOURCEUSAGE_CONTAINER,
@NetResContainer,hEnum)
else
{ Перечисляем подключаемые и возобновляемые ресурсы (другие получить здесь невозможно):
}
r:=WNetOpenEnum(ListType,ResourceType,RESOURCEUSAGE_CONTAINER,
nil,hEnum);
{ Невозможно перечислить ресурсы данного контейнера;
выводим соответствующее предупреждение и едем дальше: }
if r<>NO_ERROR then
begin
AddShareString(TopContainerIndex,'<Не могу опросить ресурсы
(Ошибка #'+
IntToStr(r)+'>');
WNetCloseEnum(hEnum);
Exit;
end;

{ Мы получили правильный дескриптор перечисления; опрашиваем ресурсы: }
while (1=1) do
begin
EntryCount:=1;
NetResLen:=SizeOf(NetRes);
r:=WNetEnumResource(hEnum,EntryCount,@NetRes,NetResLen);
case r of
0: begin
{ Другой контейнер для перечисления;
необходим рекурсивный вызов: }
if (NetRes[0].dwUsage=RESOURCEUSAGE_CONTAINER) or
(NetRes[0].dwUsage=10) then
DoEnumerationContainer(NetRes[0])
else
case NetRes[0].dwDisplayType of
{ Верхний уровень: }
RESOURCEDISPLAYTYPE_GENERIC,
RESOURCEDISPLAYTYPE_DOMAIN,
RESOURCEDISPLAYTYPE_SERVER: AddContainer(NetRes[0]);
{ Ресурсы общего доступа: }
RESOURCEDISPLAYTYPE_SHARE:
AddShare(TopContainerIndex,NetRes[0]);
end;
end;
ERROR_NO_MORE_ITEMS: Break;
else begin
MessageDlg('Ошибка #'+IntToStr(r)+' при перечислении
ресурсов.',mtError,[mbOK],0);
Break;
end;
end;
end;

{ Закрываем дескриптор перечисления: }
WNetCloseEnum(hEnum);
end;

procedure TfrmMain.FormShow(Sender: TObject);
begin
DoEnumeration;
end;

{
Добавляем элементы дерева; помечаем, что это контейнер:
}
procedure TfrmMain.AddContainer(NetRes: TNetResource);
var
ItemName: String;
begin
ItemName:=Trim(String(NetRes.lpRemoteName));
if Trim(String(NetRes.lpComment))<>'' then
begin
if ItemName<>'' then ItemName:=ItemName+' ';
ItemName:=ItemName+'('+String(NetRes.lpComment)+')';
end;
tvResources.Items.Add(tvResources.Selected,ItemName);
end;

{
Добавляем дочерние элементы к контейнеру, обозначенному как текущий верхний уровень:
}
procedure TfrmMain.AddShare(TopContainerIndex: Integer; NetRes:
TNetResource);
var
ItemName: String;
begin
ItemName:=Trim(String(NetRes.lpRemoteName));
if Trim(String(NetRes.lpComment))<>'' then
begin
if ItemName<>'' then ItemName:=ItemName+' ';
ItemName:=ItemName+'('+String(NetRes.lpComment)+')';
end;

tvResources.Items.AddChild(tvResources.Items[TopContainerIndex],ItemName);
end;

{
Добавляем дочерние элементы к контейнеру, обозначенному как текущий верхний уровень;
это просто добавляет строку для таких задач, как, например,
перечисление контейнера. То есть некоторые контейнерные
ресурсы общего доступа нам не доступны.
}
procedure TfrmMain.AddShareString(TopContainerIndex: Integer;
ItemName: String);
begin

tvResources.Items.AddChild(tvResources.Items[TopContainerIndex],ItemName);
end;

{
Добавляем соединения к дереву.
По большому счету к этому моменту все сетевые ресурсы типа
возобновляемых и текущих соединений уже отображены.
}
procedure TfrmMain.AddConnection(NetRes: TNetResource);
var
ItemName: String;
begin
ItemName:=Trim(String(NetRes.lpLocalName));
if Trim(String(NetRes.lpRemoteName))<>'' then
begin
if ItemName<>'' then ItemName:=ItemName+' ';
ItemName:=ItemName+'-> '+Trim(String(NetRes.lpRemoteName));
end;
tvResources.Items.Add(tvResources.Selected,ItemName);
end;

{
Раскрываем все контейнеры дерева:
}
procedure TfrmMain.mniExpandAllClick(Sender: TObject);
begin
tvResources.FullExpand;
end;

{
Схлопываем все контейнеры дерева:
}
procedure TfrmMain.mniCollapseAllClick(Sender: TObject);
begin
tvResources.FullCollapse;
end;

{
Записываем дерево в выбранном файле:
}
procedure TfrmMain.mniSaveToFileClick(Sender: TObject);
begin
if dlgSave.Execute then
tvResources.SaveToFile(dlgSave.FileName);
end;

{
Загружаем дерево из выбранного файла:
}
procedure TfrmMain.mniLoadFromFileClick(Sender: TObject);
begin
if dlgOpen.Execute then
tvResources.LoadFromFile(dlgOpen.FileName);
end;

{
Обновляем:
}
procedure TfrmMain.btnOKClick(Sender: TObject);
begin
DoEnumeration;
end;

end.

[000200]


Получение сетевого имени пользователя

Вы можете попробовать этот код. Я без проблем использовал его под Netware LAN в течение долгого времени. Работа программы зависит от наличия NWCALLS.DLL на машине пользователя, но если он использовал сеть хоть раз, данная библиотека должна присутствовать на его машине.

unit GetLogin;

{Данный модуль инкапсулирует несколько внешних функций библиотеки NWCALLS.DLL}
{Создан на основе кода Григория Трубецкого}
{Модуль содержит функции, возвращающие Netware User ID}
{и полное имя пользователя.}
interface
uses
SysUtils, Messages, Dialogs;
function GetUserLogin: string;
function GetUserFullName( SomeUser: string): string;

implementation
type
NWTimeStamp = record
Year:      byte;
Month:     byte;
Day:       byte;
Hour:      byte;
Minute:    byte;
Second:    byte;
DayOfWeek: byte;
end;

{Netware API - требуется NWCALLS.DLL}
function NWGetDefaultConnectionID(var Connection: word): word;
far; external 'NWCALLS';

function NWGetConnectionNumber(Connection: word; var ConnectionNumber:
word): word;
far; external 'NWCALLS';

function NWGetConnectionInformation(Connection: word;
ConnectionNumber: word;
ObjectName: pchar;
var ObjectType: word;
var ObjectID: word;
var LoginTime: NWTimeStamp):word;
far; external 'NWCALLS';

function NWReadPropertyValue(Connection:       word;
ObjectName:       pChar;
ObjectType:       word;
PropertyName:     pChar;
DataSetIndex:     byte;
DataBuffer:       pChar;
var More:             byte;
var Flags:            byte): word;
far; external 'NWCALLS';
{ конец секции работы с Netware API }

function GetUserLogin: string;
var
ConnectionID: word;
ConnectionNumber: word;
RC: word;
Name: array[0..50] of Char;
ObjectType: word;
ObjectID: word;
LoginTime: NWTimeStamp;
begin
RC := NWGetDefaultConnectionID(ConnectionID);
RC := NWGetConnectionNumber(ConnectionID, ConnectionNumber);
RC := NWGetConnectionInformation( ConnectionID,
ConnectionNumber,
Name,
ObjectType,
ObjectID,
LoginTime);

Result := StrPas(Name);
end;

function GetUserFullName( SomeUser: string): string;
{Реально имя пользователя является свойством 'IDENTIFICATON'.
Вы должны вызывать NWReadPropertyValue с параметрами (между прочим) вашего ConnectionID,
имени объекта (такое же, как и логин пользователя, сетевое имя которого мы пытаемся узнать)
и свойство name, которое нам необходимо получить, в нашем случае 'IDENTIFICATION'
(это и есть искомая величина - полное имя пользователя).}
var
ConnectionID: word;
RC: word;
Name: array[0..50] of Char;
ObjectType: word;
PropName: array[0..14] of Char;
DataSetIndex: byte;
FullName: array[0..127] of Char;
More: byte;
Flags: byte;
begin
RC := NWGetDefaultConnectionID(ConnectionID);
ObjectType := 256; {пользователь}
StrPCopy(PropName, 'IDENTIFICATION');
DataSetIndex := 1;
StrPCopy(Name, SomeUser);
RC := NWReadPropertyValue( ConnectionID,
Name,
ObjectType,
PropName,
DataSetIndex,
FullName,
More,
Flags);
if RC = 35324 then
MessageDlg('Пользователь ' + SomeUser + ' на этом сервере не обнаружен!',
mtError, [mbOK], 0);
Result := StrPas(FullName);
end;

end.

[000201]


Delphi 2

Подключение сетевого диска в Delphi

Данный код показывает как создавать кнопку 'Сеть', вызывающую диалог подключения сетевого диска и указывающего логический диск для подключаемого сетевого ресурса. Этот код создавался на Delphi 2, но и в Delphi 1 данная процедура не сильно отличается от исходной.

Создайте кнопку с именем NetBtn и drive combo box (выпадающий список с дисками) с именем DriveBox. Затем напишите следующий обработчик события OnClick кнопки:

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;

Ну и не забудьте также добавить WinProcs и WinTypes в список используемых модулей.

Самое большое неудобство заключается в том, что у DriveComboBox отсутствует функция обновления. Меняя значение свойства TextCase, мы заставляем компонент обновляться.

Авторские права © 1997 Josef Garvi [000202]


Вызов диалога подключения сетевого диска

Попробуйте WNetConnectionDialog. Данная функция инкапсулирована в Windows.pas и специально предназначена для этого. [000203]


Delphi 1

Определение своего IP адреса

Как мне определить собственный IP адрес из Delphi 1?

function my_ip_address:longint;
const
bufsize=255;
var
buf: pointer;
RemoteHost : PHostEnt; (* Не освобождайте это! *)
begin
buf:=NIL;
try
getmem(buf,bufsize);
winsock.gethostname(buf,bufsize);   (* это может работать и без сети *)
RemoteHost:=Winsock.GetHostByName(buf);
if RemoteHost=NIL then
my_ip_address:=winsock.htonl($07000001)  (* 127.0.0.1 *)
else
my_ip_address:=longint(pointer(RemoteHost^.h_addr_list^)^);
finally
if buf<>NIL then  freemem(buf,bufsize);
end;
result:=winsock.ntohl(result);
end;

Вначале возвращается локальный сетевой адрес компьютера, а затем, если он не равен 127.0.0.1, стандартный IP адрес.

Единственное, что вам необходимо, это наличие winsock.dcu/winsock.pas, так как это не включается в поставку Delphi 1.; необходимый мне код я взял из tcpip component pack (просто вырезал его оттуда). [000204]


Delphi 1

Ошибка отключения сетевого диска

Невозможно разорвать сетевое соединение?

Я потратил несколько дней, пытаясь понять почему при попытке отключения сетевого диска я получаю ошибку WN_NET_ERROR!

Когда вы задаете начальный каталог в диалоге открытия файла (в нашем случае это сетевой диск), происходит изменение текущего каталога (что логично). НО, в момент выполнения диалога (когда нажата кнопка ОК или ОТМЕНА), вы все еще подключены к диску\каталогу, который вы задали для данного диалога. Затем, когда вы пытаетесь разорвать соединение с текущим диском, WNetCancelConnection возвращает вам WN_NET_ERROR.

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

- Ted O'Neil [000776]


Создание хранителя экрана (Screen Saver)

Время от времени я наблюдаю вопросы с просьбой рассказать о процессе создания с помощью Delphi хранителя экрана, которого можно было бы выбрать с помощью панели управления (Control Panel / Desktop). После того, как я увидел несколько общих ответов, частично отвечавших на заданный вопрос, я решил создать данный совет и полностью посвятить вас в технологию создания хранителя экрана Windows от начала до конца. Приведенный ниже код позволяет создать предмет нашего разговора, а именно - простой хранитель экрана Windows.

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

Вступление

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

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

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

С самого начала

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

Прежде всего создайте новый, пустой проект, выбрав пункт New Project из меню File. (Если вы находитесь в репозитарии, выберите "Blank project".)

Конфигурационная форма

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

BorderIcons     [biSystemMenu]
  biSystemMenu  True
  biMinimize    False
  biMaximize    False
BorderStyle     bsDialog
Caption         Configuration
Height          162
Name            CfgFrm
Position        poScreenCenter
Visible         False
Width           266

Нам необходимо предоставить возможность изменять максимальное количество сфер, выводимых на экране, их размер и скорость рисования. Для того, чтобы это сделать, добавьте следующие три компонента Label (из палитры Standard) и компонент SpinEdit (из палитры Samples): (Примечание: Для быстрого размещения этих компонентов на форме скопируйте этот текст в буфер обмена и замените текст описания формы, выводимый при нажатии на пункт меню "View as Text" контекстного меню формы.)

object Label1: TLabel
Left = 16
Top = 19
Width = 58
Height = 16
Alignment = taRightJustify
Caption = 'Сфер:'
end
object Label2: TLabel
Left = 41
Top = 59
Width = 33
Height = 16
Alignment = taRightJustify
Caption = 'Размер:'
end
object Label3: TLabel
Left = 29
Top = 99
Width = 45
Height = 16
Alignment = taRightJustify
Caption = 'Скорость:'
end
object spnSpheres: TSpinEdit
Left = 84
Top = 15
Width = 53
Height = 26
MaxValue = 500
MinValue = 1
TabOrder = 0
Value = 50
end
object spnSize: TSpinEdit
Left = 84
Top = 55
Width = 53
Height = 26
MaxValue = 250
MinValue = 50
TabOrder = 1
Value = 100
end
object spnSpeed: TSpinEdit
Left = 84
Top = 95
Width = 53
Height = 26
MaxValue = 10
MinValue = 1
TabOrder = 2
Value = 10
end

Наконец, нам необходимы три кнопки -- OK, Отмена и Тест. Кнопка Тест не является стандартной для диалогов настройки хранителей экрана, но она позволяет удобно и легко проверить сделанные изменения. Добавьте следующие три кнопки, используя компоненты BitBtn из палитры "Additional":

object btnOK: TBitBtn
Left = 153
Top = 11
Width = 89
Height = 34
TabOrder = 3
Kind = bkOK
end
object btnCancel: TBitBtn
Left = 153
Top = 51
Width = 89
Height = 34
TabOrder = 4
Kind = bkCancel
end
object btnTest: TBitBtn
Left = 153
Top = 91
Width = 89
Height = 34
Caption = 'Тест...'
TabOrder = 5
Kind = bkIgnore
end

Для того, чтобы мы могли управлять формой и текущими значениями, нам необходимо создать некоторый код. Для начала мы должны обеспечить возможность загрузки и сохранения текущей конфигурации. Чтобы сделать это, мы должны сохранить значения размера и скорости рисования сфер в файле инициализации (*.INI) в директории Windows. Объект Delphi TIniFile - именно то, что нам нужно.

Перейдите к редактору кода модуля Setup и добавьте следующее объявление в секции используемых модулей:

uses
IniFiles;

Затем добавьте следующие объявления процедур в секцию private модуля TCfgFrm:

procedure LoadConfig;
procedure SaveConfig;

Теперь создайте код самих процедур после секции uses в разреле реализации:

const
CfgFile = 'SPHERES.INI';

procedure TCfgFrm.LoadConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
spnSpheres.Value := ReadInteger('Config', 'Spheres', 50);
spnSize.Value    := ReadInteger('Config', 'Size', 100);
spnSpeed.Value   := ReadInteger('Config', 'Speed', 10);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.LoadConfig}

procedure TCfgFrm.SaveConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
WriteInteger('Config', 'Spheres', spnSpheres.Value);
WriteInteger('Config', 'Size', spnSize.Value);
WriteInteger('Config', 'Speed', spnSpeed.Value);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.SaveConfig}

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

procedure TCfgFrm.FormCreate(Sender: TObject);
begin
LoadConfig;
end; {TCfgFrm.FormCreate}

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

procedure TCfgFrm.btnOKClick(Sender: TObject);
begin
SaveConfig;
Close;
end; {TCfgFrm.btnOKClick}

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

procedure TCfgFrm.btnCancelClick(Sender: TObject);
begin
Close;
end; {TCfgFrm.btnCancelClick}

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

procedure TCfgFrm.btnTestClick(Sender: TObject);
begin
ScrnFrm.Show;
end; {TCfgFrm.btnTestClick}

Затем добавьте "Scrn" в список используемых модулей в секции реализации. Scrn - это модуль формы хранителя экрана, который мы создадим в следующем шаге. Ну а пока сохраните созданный нами модуль с именем "Cfg", выбрав пункт "Save File As" в меню "File".

Форма хранителя экрана

Сам хранитель экрана будет просто большой, черной формой без заголовка, занимающей весь экран, на котором и будет разворачиваться наше представление. Для того, чтобы создать вторую форму, выберите пункт New Form в меню File или "Blank form" в репозитарии.

BorderIcons     []
  biSystemMenu  False
  biMinimize    False
  biMaximize    False
BorderStyle     bsNone
Color           clBlack
FormStyle       fsStayOnTop
Name            ScrnFrm
Visible         False

Расположите на форме единственный Delphi компонент - таймер из палитры System. Установите его свойства как указано ниже:

object tmrTick: TTimer
Enabled = False
OnTimer = tmrTickTimer
Left = 199
Top = 122 end

Больше никаких компонентов для этой формы не потребуется. Тем не менее мы должны добавить некоторый код, осуществляющий рисование затененных сфер. Переключитесь в редактор кода на модуль формы ScrnFrm. В секции private TScrnFrm добавьте следующее объявление процедуры:

procedure DrawSphere(x, y, size : integer; color : TColor);

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

procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor);
var
i, dw    : integer;
cx, cy   : integer;
xy1, xy2 : integer;
r, g, b  : byte;
begin
with Canvas do begin
{Заполняем установки карандаша и кисти.}
Pen.Style := psClear;
Brush.Style := bsSolid;
Brush.Color := color;
{Подготовим цвета для сфер.}
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
{Рисуем сферу.}
dw := size div 16;
for i := 0 to 15 do begin
xy1 := (i * dw) div 2;
xy2 := size - xy1;
Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255),
Min(b + (i * 8), 255));
Ellipse(x + xy1, y + xy1, x + xy2, y + xy2);
end;
end;
end; {TScrnFrm.DrawSphere}

Как вы можете увидеть из кода, мы задаем координаты (x,y) верхней части, левый угол сферы, а также диаметр и базовый цвет. Затем, для того, чтобы нарисовать сферу, мы создаем градиент от базового до самого яркого цвета. Изменяя шаг за шагом цвет кисти, мы рисуем и заполняем каждый раз концентрический круг меньшего диаметра.

Наверняка вы также обратили внимание на то, что функция периодически обращается другой функции, именуемой Min(). Так как это функция не является стандартной функцией Delphi, мы должны добавить ее объявление к данному модулю, выше объявления DrawSphere().

function Min(a, b : integer) : integer;
begin
if b < a then
Result := b
else
Result := a;
end; {Min}

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

procedure TScrnFrm.tmrTickTimer(Sender: TObject);
const
sphcount : integer = 0;
var
x, y    : integer;
size    : integer;
r, g, b : byte;
color   : TColor;
begin
if sphcount > CfgFrm.spnSpheres.Value then begin
Refresh;
sphcount := 0;
end;
Inc(sphcount);
x := Random(ClientWidth);
y := Random(ClientHeight);
size := CfgFrm.spnSize.Value + Random(50) - 25;
x := x - size div 2;
y := y - size div 2;
r := Random($80);
g := Random($80);
b := Random($80);
DrawSphere(x, y, size, RGB(r, g, b));
end; {TScrnFrm.tmrTickTimer}

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

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

uses
Cfg;

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

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

var
crs : TPoint;

Эта переменная необходима для хранения оригинальной позиции курсора мыши для ее последующего сравнения. Теперь добавьте следующее объявление в секции private модуля TScrnFrm:

procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);

Добавьте соответствующий код в секцию реализации модуля:

procedure TScrnFrm.DeactivateScrnSaver(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
done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_ACTIVATE) or
(Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_NCACTIVATE);
if done then
Close;
end; {TScrnFrm.DeactivateScrnSaver}

При получении системного сообщения WM_MOUSEMOVE мы сравниваем новые координаты мыши с оригинальными. Если перемещение мыши превысило допустимое значение (в нашем случае порог составляет 5 пикселей), закрываем хранитель экрана. Далее проверяем нажатие клавиши или передачу фокуса другому окну или диалогу, и в этом случае также закрываем хранитель.

Чтобы процедура работала, нам нужно передать обработчику события Application.OnMessage оригинальную позицию курсора мыши. Лучшее место для получения координат курсора находится в обработчике события формы OnShow:

procedure TScrnFrm.FormShow(Sender: TObject);
begin
GetCursorPos(crs);
tmrTick.Interval      := 1000 - CfgFrm.spnSpeed.Value * 90;
tmrTick.Enabled       := true;
Application.OnMessage := DeactivateScrnSaver;
ShowCursor(false);
end; {TScrnFrm.FormShow}

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

procedure TScrnFrm.FormHide(Sender: TObject);
begin
Application.OnMessage := nil;
tmrTick.Enabled       := false;
ShowCursor(true);
end; {TScrnFrm.FormHide}

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

procedure TScrnFrm.FormActivate(Sender: TObject);
begin
WindowState := wsMaximized;
end; {TScrnFrm.FormActivate}

Сохраните созданный нами модуль ScrnFrm под именем "SCRN.PAS", выбрав пункт Save File в меню File.

Описание хранителя экрана

Вы можете определить текст, который появится в списке хранителей экранов в Control Panel / Desktop, добавив директиву {$D текст} к исходному файлу проекта. Директива $D вставляет текст в описание модуля выполняемого файла. Чтобы Панель Управления "поняла" этот текст и принадлежность файла к хранителям экрана, описание должно начинаться с зарезервированного слова "SCRNSAVE".

Выберите пункт Project Source из меню View для редактирования исходного кода проекта. Под директивой "{$R *.RES}" добавьте следующую строчку:

{$D SCRNSAVE Spheres Screen Saver}

Теперь при выводе списка доступных хранителей экранов в Контрольной Панели вы увидите текст "Spheres Screen Saver", позволяющий выбрать ваш маленький шедевр.

Активный режим и режим конфигурации

Windows запускает программу хранителя экрана при двух возможных условиях: 1) при активизации хранителя экрана, и 2) когда необходимо изменить его настройки. В обоих случаях Windows запускает одну и ту же программу. Для запуска программы в одном из двух режимов предусмотрен параметр командной строки - "/s" для активного режима и "/c" для режима конфигурации. Для корректной работы с Панелью управления наш хранитель экрана должен проверять командную строку на предмет наличия одного из ключа.

Активный режим

Когда хранитель экрана стартует в активном режиме (/s), нам необходимо создать и показать именно форму хранителя экрана. Но при этом нам также необходимо создать и форму конфигурации, поскольку она содержит все конфигурационные настройки. При закрытии формы хранителя экрана программа завершает свою работу. В этом режиме форма хранителя экрана является главной формой приложения - она запускается при старте приложения и при ее закрытии приложение завершается.

Режим конфигурации

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

Определение главной формы

В нашем случае нам необходимо идентифицировать ScrnFrm как главную форму приложения, если в командной строке присутствовал параметр /s, в противном случае главной формой приложения должна быть форма CfgFrm. Чтобы это сделать, необходимо знать одну недокументированную характеристику VCL объекта TApplication: главной формой приложения становится первая форма, создаваемая вызовом Application.CreateForm(). Таким образом, для определения главной формы приложения согласно параметрам, передаваемым во время выполнения программы, следует отредактировать исходный код проекта следующим образом:

begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin
{ScrnFrm должна быть главной формой.}
Application.CreateForm(TScrnFrm, ScrnFrm);
Application.CreateForm(TCfgFrm, CfgFrm);
end else begin
{CfgFrm должна быть главной формой.}
Application.CreateForm(TCfgFrm, CfgFrm);
Application.CreateForm(TScrnFrm, ScrnFrm);
end;
Application.Run;
end.

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

(Примечание: для обеспечения показанной выше функциональности необходимо выключить опцию "Complete boolean eval" в пункте меню Options | Project | Compiler settings. В противном случае при отсутствии параметров командной строки будет возникать ошибка.)

Для использования Delphi функции UpperCase(), необходимо включить модуль SysUtils в список используемых модулей исходного кода проекта как показано ниже:

uses
Forms, SysUtils,
Scrn in 'SCRN.PAS' {ScrnFrm},
Cfg in 'CFG.PAS' {CfgFrm};

Блокировка запуска второй копии

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

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

begin
{Возможен запуск только одной копии.}
if hPrevInst = 0 then begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin
...
end;
Application.Run;
end;
end;

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

Теперь сохраните файл проекта с именем "SPHERES.DPR" и скомпилируйте программу. Вот мы и получили хранитель экрана, полностью удовлетворяющий всем нашим требованиям. В случае отсутствия параметров в командной строке программа переходит в режим конфигурации, заданный по умолчанию. Вы можете протестировать активный режим, передавая в командной строке первым параметр "/s". (Смотри Run | Parameters...)

Установка хранителя экрана

После отладки и проверки хранителя экрана вы уже можете его установить и использовать в системе. Для этого скопируйте исполняемый файл (SPHERES.EXE) в директорию Windows и измените его расширение на .SCR, в результате чего вы получите файл с именем SPHERES.SCR. Затем, войдя в Панель Управления, дважды щелкните на иконке Desktop, и выберите Screen Saver | Name. Вы должны увидеть "Spheres Screen Saver" в списке доступных хранителей экрана. Выбрав его и нажав на кнопку ОК, вы тем самым сделаете его активным системным хранителем.

Полный исходный код проекта хранителя экрана

Cfg.dfm

object CfgFrm: TCfgFrm
Left = 196
Top = 124
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Конфигурация'
ClientHeight = 135
ClientWidth = 258
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
Position = poScreenCenter
OnCreate = FormCreate
TextHeight = 16
object Label1: TLabel
Left = 16
Top = 19
Width = 58
Height = 16
Alignment = taRightJustify
Caption = 'Сфер:'
end
object Label2: TLabel
Left = 41
Top = 59
Width = 33
Height = 16
Alignment = taRightJustify
Caption = 'Размер:'
end
object Label3: TLabel
Left = 29
Top = 99
Width = 45
Height = 16
Alignment = taRightJustify
Caption = 'Скорость:'
end
object spnSpheres: TSpinEdit
Left = 84
Top = 15
Width = 53
Height = 26
MaxValue = 500
MinValue = 1
TabOrder = 0
Value = 50
end
object spnSize: TSpinEdit
Left = 84
Top = 55
Width = 53
Height = 26
MaxValue = 250
MinValue = 50
TabOrder = 1
Value = 100
end
object spnSpeed: TSpinEdit
Left = 84
Top = 95
Width = 53
Height = 26
MaxValue = 10
MinValue = 1
TabOrder = 2
Value = 10
end
object btnOK: TBitBtn
Left = 153
Top = 11
Width = 89
Height = 34
TabOrder = 3
OnClick = btnOKClick
Kind = bkOK
end
object btnCancel: TBitBtn
Left = 153
Top = 51
Width = 89
Height = 34
TabOrder = 4
OnClick = btnCancelClick
Kind = bkCancel
end
object btnTest: TBitBtn
Left = 153
Top = 91
Width = 89
Height = 34
Caption = 'Тест...'
TabOrder = 5
OnClick = btnTestClick
Kind = bkIgnore
end
end

Cfg.pas

unit Cfg;

interface

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

type
TCfgFrm = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
spnSpheres: TSpinEdit;
spnSize: TSpinEdit;
spnSpeed: TSpinEdit;
btnOK: TBitBtn;
btnCancel: TBitBtn;
btnTest: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnTestClick(Sender: TObject);
private
{ Private declarations }
procedure LoadConfig;
procedure SaveConfig;
public
{ Public declarations }
end;

var
CfgFrm: TCfgFrm;

implementation

{$R *.DFM}

uses
Scrn,
IniFiles;

const
CfgFile = 'SPHERES.INI';

procedure TCfgFrm.LoadConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
spnSpheres.Value := ReadInteger('Config', 'Spheres', 50);
spnSize.Value    := ReadInteger('Config', 'Size', 100);
spnSpeed.Value   := ReadInteger('Config', 'Speed', 10);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.LoadConfig}

procedure TCfgFrm.SaveConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
WriteInteger('Config', 'Spheres', spnSpheres.Value);
WriteInteger('Config', 'Size', spnSize.Value);
WriteInteger('Config', 'Speed', spnSpeed.Value);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.SaveConfig}

procedure TCfgFrm.FormCreate(Sender: TObject);
begin
LoadConfig;
end; {TCfgFrm.FormCreate}

procedure TCfgFrm.btnOKClick(Sender: TObject);
begin
SaveConfig;
Close;
end; {TCfgFrm.btnOKClick}

procedure TCfgFrm.btnCancelClick(Sender: TObject);
begin
Close;
end; {TCfgFrm.btnCancelClick}

procedure TCfgFrm.btnTestClick(Sender: TObject);
begin
ScrnFrm.Show;
end; {TCfgFrm.btnTestClick}

end.

SCRN.dfm

object ScrnFrm: TScrnFrm
Left = 196
Top = 98
BorderIcons = []
BorderStyle = bsNone
Caption = 'ScrnFrm'
ClientHeight = 101
ClientWidth = 259
Color = clBlack
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
FormStyle = fsStayOnTop
OldCreateOrder = True
OnActivate = FormActivate
OnHide = FormHide
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 16
object tmrTick: TTimer
Enabled = False
OnTimer = tmrTickTimer
Left = 65535
Top = 2
end
end

SCRN.pas

unit Scrn;

interface

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

type
TScrnFrm = class(TForm)
tmrTick: TTimer;
procedure tmrTickTimer(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
procedure DrawSphere(x, y, size : integer; color : TColor);
procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);
public
{ Public declarations }
end;

var
ScrnFrm: TScrnFrm;

implementation

{$R *.DFM}

uses
Cfg;

var
crs : TPoint;  {Оригинальная позиция курсора мыши.}

function Min(a, b : integer) : integer;
begin
if b < a then
Result := b
else
Result := a;
end; {Min}
procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor);
var
i, dw    : integer;
cx, cy   : integer;
xy1, xy2 : integer;
r, g, b  : byte;
begin
with Canvas do begin
{Заполняем установки карандаша и кисти.}
Pen.Style := psClear;
Brush.Style := bsSolid;
Brush.Color := color;
{Подготовим цвета для сфер.}
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
{Рисуем сферу.}
dw := size div 16;
for i := 0 to 15 do begin
xy1 := (i * dw) div 2;
xy2 := size - xy1;
Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255),
Min(b + (i * 8), 255));
Ellipse(x + xy1, y + xy1, x + xy2, y + xy2);
end;
end;
end; {TScrnFrm.DrawSphere}

procedure TScrnFrm.DeactivateScrnSaver(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
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; {TScrnFrm.DeactivateScrnSaver}

procedure TScrnFrm.tmrTickTimer(Sender: TObject);
const
sphcount : integer = 0;
var
x, y    : integer;
size    : integer;
r, g, b : byte;
color   : TColor;
begin
if sphcount > CfgFrm.spnSpheres.Value then begin
Refresh;
sphcount := 0;
end;
Inc(sphcount);
x := Random(ClientWidth);
y := Random(ClientHeight);
size := CfgFrm.spnSize.Value + Random(50) - 25;
x := x - size div 2;
y := y - size div 2;
r := Random($80);
g := Random($80);
b := Random($80);
DrawSphere(x, y, size, RGB(r, g, b));
end; {TScrnFrm.tmrTickTimer}

procedure TScrnFrm.FormShow(Sender: TObject);
begin
GetCursorPos(crs);
tmrTick.Interval      := 1000 - CfgFrm.spnSpeed.Value * 90;
tmrTick.Enabled       := true;
Application.OnMessage := DeactivateScrnSaver;
ShowCursor(false);
end; {TScrnFrm.FormShow}

procedure TScrnFrm.FormHide(Sender: TObject);
begin
Application.OnMessage := nil;
tmrTick.Enabled       := false;
ShowCursor(true);
end; {TScrnFrm.FormHide}

procedure TScrnFrm.FormActivate(Sender: TObject);
begin
WindowState := wsMaximized;
end; {TScrnFrm.FormActivate}

end.

Spheres.dpr

program Spheres;

uses
Forms, SysUtils,
Scrn in 'SCRN.PAS' {ScrnFrm},
Cfg in 'CFG.PAS' {CfgFrm};

{$R *.RES}
{$D SCRNSAVE Spheres Screen Saver}

begin
{Возможен запуск только одной копии.}
if hPrevInst = 0 then begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin
{ScrnFrm должна быть главной формой.}
Application.CreateForm(TScrnFrm, ScrnFrm);
Application.CreateForm(TCfgFrm, CfgFrm);
end else begin
{CfgFrm должна быть главной формой.}
Application.CreateForm(TCfgFrm, CfgFrm);
Application.CreateForm(TScrnFrm, ScrnFrm);
end;
Application.Run;
end;
end.

Spheres.opt

[Compiler]
A=1
B=0
D=1
F=0
I=1
K=1
L=1
P=1
Q=0
R=0
S=1
T=0
U=1
V=1
W=0
X=1
Y=1

[Linker]
MapFile=0
LinkBuffer=0
DebugInfo=0
OptimizeExe=1
StackSize=16384
HeapSize=8192

[Directories]
OutputDir=
SearchPath=
Conditionals=

[Parameters]
RunParams=/s
[000236]


Рассуждения о потоках

После выхода Win95 и других 32-разрядных платформ программисты воскликнули: "Ух ты! Потоки!"

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

Итог: Умножение потоков не умножает CPU.

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

Итог: Использование потоков для перекрытия обработки I/O.

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

Итог: Расставляйте приоритеты потоков в зависимости от задач.

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

Итог: Конкуренция за обладание ресурсами.

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

Итог: Борьба за пользовательский интерфейс.

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

Итог: Управляйте нагрузкой... если есть инструмент для этого.

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

Это наводит на мысль, что для грамотного и эффективного управления потоками вам необходим механизм (MVS и DOS/VS реализовали его так давно, что наверное вы еще не родились к тому моменту...), или "монитор транзакций", или другие части программного обеспечения, встраиваемые в ваше приложение и позволяющие организовывать очереди и регулировать рабочие потоки для многопользовательского или серверного режима.

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

Итог: Помните, что память виртуальна.

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

Итог: Заявляйте о себе открыто.

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

Итог: Делегируйте обязанности, все время.

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

[000261]


Сокращенное имя каталога

Есть имя каталога:

c:\windows\media\temp\abc\sound\chime.wav

Мне необходима сокращенная запись, такая как

c:\windows\..\sound\chime.wav

а не полный путь к файлу.

Есть ли простой способ для этого?

Я разработал процедуру, которая делает нечто похожее. Она сокращает имя каталога, когда он и текущий путь имеют в корне тот же диск и/или часть пути, совпадающие вначале. Полученный результат (сокращенная запись) действительно легче для восприятия. Я производил кодирование в шестнадцатиричном редакторе в Borland Pascal и некоторое время не использовал. Я не думаю, что данный код может быть несовместим с последними версиями Delphi.

function shortenfilename(s : string) : string;
var drive,curdrive : string[2];
dir,curdir : string[80];
name : string[20];
ext : string[5];
i : byte;
begin
for i:=1 to length(s) do s[i]:=upcase(s[i]);
s:=fexpand(s);
fsplit(s,dir,name,ext);
drive:=copy(dir,1,2);
dir:=copy(dir,4,length(dir)-3);
getdir(0,curdir);
curdrive:=copy(curdir,1,2);
curdir:=copy(curdir,4,length(curdir)-3)+'\';
if drive=curdrive then begin
if copy(dir,1,length(curdir))=curdir then begin
i:=length(curdir);
if length(dir)<>i then dir:=dir+'\';
shortenfilename:=copy(dir,i+1,length(dir)-i-1)+name+ext;
end else shortenfilename:=copy(s,3,length(s)-2);
end else shortenfilename:=s;
end;
[000078]


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

Запуск приложения в полноэкранном режиме означает, что окно приложения полностью занимает рабочий стол. Это бывает необходимо для обеспечения поддержки функции акселератора видеокарты, которая может ускорить работу только полной области экрана, но не только, к примеру, если вам необходимо сделать только вашу программу видимой для пользователя. Кстати: Полноэкранный запуск в общих чертах имеет отношение не только к OpenGL, DirectX и 3D. Строго говоря полноэкранный режим требует только установки флага состояния окна wsMaximize, и все.

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

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

function SetFullscreenMode(ModeIndex: Integer) : Boolean;
// изменение видеорежима, задаваемого 'ModeIndex'
var DeviceMode : TDevMode;
begin
with DeviceMode do
begin
dmSize:=SizeOf(DeviceMode);
dmBitsPerPel:=VideoModes[ModeIndex].ColorDepth;
dmPelsWidth:=VideoModes[ModeIndex].Width;
dmPelsHeight:=VideoModes[ModeIndex].Height;
dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
// при неудачной смене режима переходим в режим текущего разрешения
Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
if Result then ScreenModeChanged:=True;
if ModeIndex = 0 then ScreenModeChanged:=False;
end;
end;

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

const MaxVideoModes = 200; // это не очень актуально
type TVideoMode = record
Width,
Height,
ColorDepth  : Word;
Description : String[20];
end;

var VideoModes        : array[0..MaxVideoModes] of TVideoMode;
NumberVideomodes  : Integer = 1; // 1, поскольку есть режим по умолчанию

Как вы видите, это делает наш пример более функциональным для использования. При необходимомости, вы можете заменить в вышеуказанной функции VideoModes на фиксированные значения (скажем, на 640, 480, 16). Перечисление всех видеорежимов осуществляется при помощи EnumDisplaySettings:

procedure ReadVideoModes;
var I, ModeNumber : Integer;
done          : Boolean;
DeviceMode    : TDevMode;
DeskDC        : HDC;

begin
// создание режима "по умолчанию"
with VideoModes[0] do
try
DeskDC:=GetDC(0);
ColorDepth:=GetDeviceCaps(DeskDC,BITSPIXEL);
Width:=Screen.Width;
Height:=Screen.Height;
Description:='default';
finally
ReleaseDC(0,DeskDC);
end;

// перечисляем все доступные видеорежимы
ModeNumber:=0;
done:=False;
repeat
done:=not EnumDisplaySettings(nil,ModeNumber,DeviceMode);
TryToAddToList(DeviceMode);
Inc(ModeNumber);
until (done or (NumberVideomodes >= MaxVideoModes));

// режимы низкого разрешения не всегда перечислимы, о них запрашивают явно
with DeviceMode do
begin
dmBitsPerPel:=8;
dmPelsWidth:=42;
dmPelsHeight:=37;
dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
// тест видеодрайвера: убедимся, что он справится со всеми видеорежимами
if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then
begin
I:=0;
while (I < NumberLowResModes-1) and (NumberVideoModes < MaxVideoModes) do
begin
dmSize:=Sizeof(DeviceMode);
dmBitsPerPel:=LowResModes[I].ColorDepth;
dmPelsWidth:=LowResModes[I].Width;
dmPelsHeight:=LowResModes[I].Height;
dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
TryToAddToList(DeviceMode);
Inc(I);
end;
end;
end;
end;

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

type TLowResMode = record
Width,
Height,
ColorDepth  : Word;
end;

const NumberLowResModes = 60;
LowResModes       : array[0..NumberLowResModes-1] of TLowResMode =
((Width:320;Height:200;ColorDepth: 8),(Width:320;Height:200;ColorDepth:15),
(Width:320;Height:200;ColorDepth:16),(Width:320;Height:200;ColorDepth:24),
(Width:320;Height:200;ColorDepth:32),(Width:320;Height:240;ColorDepth: 8),
(Width:320;Height:240;ColorDepth:15),(Width:320;Height:240;ColorDepth:16),
(Width:320;Height:240;ColorDepth:24),(Width:320;Height:240;ColorDepth:32),
(Width:320;Height:350;ColorDepth: 8),(Width:320;Height:350;ColorDepth:15),
(Width:320;Height:350;ColorDepth:16),(Width:320;Height:350;ColorDepth:24),
(Width:320;Height:350;ColorDepth:32),(Width:320;Height:400;ColorDepth: 8),
(Width:320;Height:400;ColorDepth:15),(Width:320;Height:400;ColorDepth:16),
(Width:320;Height:400;ColorDepth:24),(Width:320;Height:400;ColorDepth:32),
(Width:320;Height:480;ColorDepth: 8),(Width:320;Height:480;ColorDepth:15),
(Width:320;Height:480;ColorDepth:16),(Width:320;Height:480;ColorDepth:24),
(Width:320;Height:480;ColorDepth:32),(Width:360;Height:200;ColorDepth: 8),
(Width:360;Height:200;ColorDepth:15),(Width:360;Height:200;ColorDepth:16),
(Width:360;Height:200;ColorDepth:24),(Width:360;Height:200;ColorDepth:32),
(Width:360;Height:240;ColorDepth: 8),(Width:360;Height:240;ColorDepth:15),
(Width:360;Height:240;ColorDepth:16),(Width:360;Height:240;ColorDepth:24),
(Width:360;Height:240;ColorDepth:32),(Width:360;Height:350;ColorDepth: 8),
(Width:360;Height:350;ColorDepth:15),(Width:360;Height:350;ColorDepth:16),
(Width:360;Height:350;ColorDepth:24),(Width:360;Height:350;ColorDepth:32),
(Width:360;Height:400;ColorDepth: 8),(Width:360;Height:400;ColorDepth:15),
(Width:360;Height:400;ColorDepth:16),(Width:360;Height:400;ColorDepth:24),
(Width:360;Height:400;ColorDepth:32),(Width:360;Height:480;ColorDepth: 8),
(Width:360;Height:480;ColorDepth:15),(Width:360;Height:480;ColorDepth:16),
(Width:360;Height:480;ColorDepth:24),(Width:360;Height:480;ColorDepth:32),
(Width:400;Height:300;ColorDepth: 8),(Width:400;Height:300;ColorDepth:15),
(Width:400;Height:300;ColorDepth:16),(Width:400;Height:300;ColorDepth:24),
(Width:400;Height:300;ColorDepth:32),(Width:512;Height:384;ColorDepth: 8),
(Width:512;Height:384;ColorDepth:15),(Width:512;Height:384;ColorDepth:16),
(Width:512;Height:384;ColorDepth:24),(Width:512;Height:384;ColorDepth:32));

И остается функция TryToAddToList:

procedure TryToAddToList(DeviceMode: TDevMode);
// Добавление видеорежима к списку, это это не дубликат и режим действительно может быть установлен.
var I : Integer;
begin
// Смотрим на предмет дублирования видеорежима (такое может быть из-за показателя
// частоты смены кадров или из-за того, что мы явно пробуем все режимы низкого разрешения)
for I:=1 to NumberVideomodes-1 do
with DeviceMode do
if ((dmBitsPerPel = VideoModes[I].ColorDepth) and
(dmPelsWidth  = VideoModes[I].Width)      and
(dmPelsHeight = VideoModes[I].Height))    then Exit; // повтор видеорежима (дубликат)

// устанавливаем тестируемый режим (на самом деле мы не устанавливаем данный режим, а хотим получить сообщение о его поддержке видеокартой).
if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then Exit;

// если это новый, поддерживаемый режим, то добавляем его к списку
with DeviceMode do
begin
VideoModes[NumberVideomodes].ColorDepth:=dmBitsPerPel;
VideoModes[NumberVideomodes].Width:=dmPelsWidth;
VideoModes[NumberVideomodes].Height:=dmPelsHeight;
VideoModes[NumberVideomodes].Description:=Format('%d x %d, %d bpp',[dmPelsWidth,dmPelsHeight,dmBitsPerPel]);
end;
Inc(NumberVideomodes);
end;

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

procedure RestoreDefaultMode;
// восстанавливаем видеорежим по умолчанию
var T : TDevMode absolute 0; // маленькая хитрость: создаем указатель на ноль
begin
// Так как первый параметр является переменной, мы не можем использовать ноль
// непосредственно. Взамен мы используем переменную с абсолютным адресом нуля.
ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;

[000107]


Показ иконки зарегистрированного расширения

Прислал Aleksey msalex@tomcat.ru:

{процедура показывает иконку в заголовке окна, используемую для, интерисующего вас, зарегистрированного расширения файла}
{Не забудьте - ShellAPI поместить в uses}

procedure ShowIcon;
var
W : Word;
begin
W := 0;
Form1.Icon.Handle := {изображение иконки вы увидите в заголовке окна}
{можно, конечно, посмотреть его и в TImage: для этого вместо "Form1.Icon.Handle" напишите "Image1.Picture.Icon.Handle"}
ExtractAssociatedIcon(HInstance,
Pchar('c:\windows\*.txt'{узнаем, например, какая иконка
используется для текстового файла.
вы можете указать конкретный файл с любым расширением}), W);
end;
[000114]


Автоматический выбор произвольный пункт PopupMenu

Прислал Aleksey msalex@tomcat.ru:

{Так можно заставить сразу, после появления на экране
PopupMenu, автоматически выбирать произвольный пункт.}

procedure TForm1.Button1Click(Sender: TObject);
var
I, N : Integer;
begin
N := 3 ; {номер по порядку}
for I := 1 to N do
PostMessage(Self.Handle, WM_KeyDown, VK_DOWN, 0);
end;
[000115]


Сохранение параметров шрифта в 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;

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

[000224]


Определение версии Windows

Посмотрите в электронной справке API и модуле WINPROCS описание и декларацию функции GetVersion: LongInt;

Функция GetVersion возвращает текущие номера версий операционных систем Windows и MS-DOS.

Примечание: в оригинальной документации по API-функциям есть ошибка: возвращаются обе версии Win - общая и сборки (major/minor)!

Результаты использования функции:

Windows 3.1 возвращает 3.1, WIN95 возвращает 3.95

Примечание Под windows 95 и выше используйте функцию GetVersionEx

Дополнение

К большому сожалению с помощью функции GetVersionEx нельзя определить "точно" версию Windows. Можно у знать номер, описание платформы (Win32&95, Win32, nonWin32), но назвать ее сложно. Возвращаемый результат имеет такую структуру:

  • dwOSVersionInfoSize
  • dwMajorVersion
  • dwMinorVersion
  • dwBuildNumber
  • dwPlatformId
  • szCSDVersion
Для людей, которым нужно просто "обозвать" Windows типа "Windows95" или "Windows98" советую читать это из глубин реестра или воспользоваться следующей функцией:

function GetWinVersion:String;
{не забудьте подключить модуль Registry}
var
Reg:TRegIniFile; {ипользуем TRegIniFile, а не TRegistry для совместимости с Win 3.1 и ниже}
HK: HKEY; { type HKEY = Integer }
begin
//  Интересующие нас данные лежат в LOCAL_MACHINE...
RegCreateKey(HKEY_LOCAL_MACHINE,'Software\Microsoft\Windows',HK);
Reg:=TRegIniFile.Create('');
Reg.RootKey:=HK;
//  Читаем версию Windows...
GetWinVersion:=Reg.ReadString('CurrentVersion','Version','');
Reg.Free;
end;

Igor Popov. E-mail to: igp@ukrpost.net.

Дополнение

Vasili Pincuk предостерегает:

Если у меня NT, то ключа
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Version
нет по определению, есть например
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion

Вопрос об удобной функции для определения версии Windows остается открытым... [000278]


Delphi 1

Запуск калькулятора Windows

procedure TForm1.Button1Click(Sender: TObject);
Var
w1: Word;
p1,p2: array[0..100] of Char;
begin
StrPcopy(p1,'CALC');
IF GetModuleHandle(p1)=0 THEN begin
StrPcopy(p2,'C:\windows\Calc.exe');
w1:=WinExec(p2,SW_Restore);
end;
end;
[000394]


Определение версии DOS и Windows

Как мне получить номер версии Windows или DOS?

Функция API GetVersion делает это, но вся информация "кодируется" в longint. Вот как получить и декодировать информацию6:

Type
TGetVer = record
WinVer,
WinRev,
DosRev,
DosVer: Byte;
end;

const
VerStr = '%d.%d';

procedure TForm1.Button1Click(Sender: TObject);
var
AllVersions: TGetVer;
begin
AllVersions := TGetVer(GetVersion);
Edit1.Text := Format(VerStr, [AllVersions.WinVer, AllVersions.WinRev]);
Edit2.Text := Format(VerStr, [AllVersions.DOSVer, AllVersions.DOSRev]);
end;

Примечание1: Значения, показываемые в информационном диалоге "О системе", не всегда совпадают со значениями, возвращаемыми описанной API функцией, например, Windows for workgroup (Windows для рабочих груп) возвращается как 3.10, а не как 3.11.

Примечание2: Приложения Win32 вместо функции GetVersion должны использовать фунцию GetVersionEx.

Дополнение

Vasili Pincuk пишет:

В VCLUtils.pas есть прекрасная функция GetWindowsVersion зачем изобретать велосипед ? К тому же пример хорошего стиля программирования. Если уж лень искать в исходниках, то ниже её текст. У меня версия от D3 (без Windows 2000 был бы рад - если кто поделится)

function GetWindowsVersion: string;
{$IFDEF WIN32}
const
sWindowsVersion = 'Windows %s %d.%.2d.%.3d %s';
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, [Platform, dwMajorVersion,
dwMinorVersion, dwBuildNumber, szCSDVersion]));
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}

[000472]


Delphi 1

Изменение шрифта у текста всплывающей подсказки

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

Type
TMyHintWindow = Class (THintWindow)
Constructor Create (AOwner: TComponent); override;
end;

Constructor TMyHintWindow.Create (AOwner: TComponent);
Begin
Inherited Create (Aowner);
Canvas.Font.Name := 'Times New Roman';
Canvas.Font.Size := 14;
end;

procedure TForm1.FormCreate(Sender: TObject); begin
Application.ShowHint := False;
HintWindowClass := TMyHintWindow;
Application.ShowHint := True;
end;

end.

[000661]


Delphi 1

Всплывающие подсказки у выключенных кнопок

Проблема заключается в том, что свойство Parent у выключенной (disabled) кнопки равно NIL. Я не уверен что это так, но это становится проблемой в ActivateHint. Если кнопка выключена, то даже при наличии над ней курсора мыши и включенной подсказки, появится.... правильно, подсказка ФОРМЫ....

OK, давайте лечить. Метод FindDragTarget вызывается в коде-обработчике подсказки, и позволяет увидеть компонент, находящийся в данный момент под курсорм мыши. FindDragTarget вызывает функцию Windows API WindowFromPoint. И WindowFromPoint *НЕ* возвращает "выключенные" окна. В электронной справке по API говорится, что если вам необходимы также выключенные окна, используйте ChildWindowFromPoint. ОГО! Это идея. Если элемент управления выключен, то будет найдена или сама форма, или же контейнер выключенного компонента. Если компонент, найденый с помощью ChildWindowFromPoint отличается от найденного с помощью WindowFromPoint, мы должны высветить подсказку. Это работает! Но хочу предостеречь: вы не сможете таким образом получить подсказку для самой формы или контейнеров типа TPanel или TGroupBox. Попытайтесь сами!

procedure TForm1.AppShowHint(var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo);
VAR
PT  : TPoint;
H   : HWnd;
TWC : TWinControl;
begin
IF NOT (HintInfo.HintControl IS TWinControl) THEN Exit;
GetCursorPos(PT);
PT  := HintInfo.HintControl.ScreenToClient(PT);
H   := ChildWindowFromPoint(TWinControl(HintInfo.HintControl).Handle, PT);
TWC := FindControl(H);
IF TWC = NIL THEN Exit;
IF TWC = Self THEN CanShow := False
ELSE IF TWC = HintInfo.HintControl then exit   (эту строку добавил Tim Frost}
ELSE IF TWC.ControlCount > 0 THEN CanShow := False
ELSE
WITH TWC DO
IF ShowHint AND (Hint <> '') THEN
BEGIN
HintStr := '(выключен) ' +Hint;
HintInfo.HintPos := ClientOrigin;
Inc(HintInfo.HintPos.Y, Height + 6);
END;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := AppShowHint;
end;

- Neil J. Rubenking [000743]


Delphi 1

Как использовать Список Задач (Tasklist)

Вот пример:

procedure TForm1.Button1Click(Sender: TObject);
{Размещаем имена модулей запущенных/минимизированных задач в ListBox    }
var
pTask : pTaskEntry;                            {требуется Uses ToolHelp}
Task  : bool;
Pstr  : array [0..79] of Char;
Str   : string[80];
byt_j : byte;
begin
ListBox1.Clear;
GetMem(pTask, SizeOf(TTaskEntry));     {Резервируем память для TaskEntry}
pTask^.dwSize:=SizeOf(TTaskEntry);

byt_j:=0;                    {Устанавливаем счетчик для количества задач}
Task:=TaskFirst(pTask);                              {Ищем первую задачу}
While task do
begin
inc(byt_j);                       {счетчик количества различных задач}
Str:=StrPas(pTask^.szModule); {Преобразуем PStr в паскалевскую строку}
Listbox1.Items.Add(str);     {Сохраняем паскалевскую строку в ListBox}
task:=taskNext(pTask);               {Ищем следующую возможную задачу}
end;
Label1.Caption:=IntToStr(byt_j)+ ' задач найдено';   {Показываем счетчик}
end;

- Daniel Kinnaer [000805]


Занесение сообшения в EventLog (Windows NT)

Alex V. Novikov пишет:

Я постоянно читаю конференции по дельфи и частенько встечается вопрос как занести свое сообщение в EventLog Windows NT. Недавно покопавшись в исходниках VCL я обнаружил такой интересный класс:

Unit SvcMgr;

{--Skip--}

{ TEventLogger }

TEventLogger = class(TObject)
private
FName: String;
FEventLog: Integer;
public
constructor Create(Name: String);
destructor Destroy; override;
procedure LogMessage(Message: String; EventType: DWord = 1;
Category: Word = 0; ID: DWord = 0);
end;

{--Skip--}

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

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

with TEventLogger.Create('My Application') do
try
LogMessage('Страшенная ошибка');
finally
Free;
end;

P.S. надеюсь это кому нибудь поможет [000890]


Delphi 1

Win95 или WinNT для Delphi 1.0

Тема: TBitBtn и Win95

Я не могу понять каким образом моя 16-битная программа может различить Win95 и WinNT.

Const WF_WINNT = $4000;

IsNT := (GetWinFlags and WF_WINNT) <> 0;

- Peter Below [000960]


Смена иконки BitBtn во время работы приложения

Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам Delphi, этим должен заниматься метод "Assign". Ниже приведен код всей процедуры замены иконки.
implementation

{$R *.DFM}

var n: integer;  // При инициализации программы данное значение будет равным нулю

procedure TForm1.Button1Click(Sender: TObject);
var Image: TBitmap;
begin // Изменение иконки в BitBtn1
Image:= TBitmap.Create;
if n < ImageList1.Count then
ImageList1.GetBitmap(n, Image);
{end if}

BitBtn1.Glyph.Assign(Image)   // Примечание: Для изменения свойств объекта используется метод Assign

inc(n,2); // В данный момент кнопка содержит две иконки!
if n > ImageList1.Count then
n:= 0;
{end if}
Image.Free;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin // добавляем новую иконку кнопки в список ImageList1
if OpenDialog1.Execute then
ImageList1.FileLoad(rtBitMap,OpenDialog1.FileName,clBtnFace);
label1.Caption:= 'Количество иконок = ' + IntToStr(ImageList1.Count);
end;
[000042]


Delphi 1

Мутация кнопок

Для цветных кнопок есть простое решение: используйте TBitBtn. Если не хотите, не используйте изображение на кнопке, но свойство Font.Color даст нужный эффект. Если же на вашей форме уже расположены стандартные кнопки, вы легко можете изменить их на TBitBtns, следуя этим шагам:

  1. Щелкните на кнопке в дизайнере форм
  2. Нажмите Ctrl+X для перемещения ее в буфер обмена
  3. Переключитесь в редактор и переместитесь к заключительному "end."
  4. Нажмите Ctrl+V для вставки копии текста кнопки
  5. Измените тип в первой строке с TButton на TBitBtn
  6. Выделите скопированный текст кнопки и переместите его в буфер обмена
  7. Вставьте его снова в дизайнер форм.
[000390]


Delphi 1

Кнопка с несколькими строчками текста I

Приведу способ, как сделать кнопку с тремя (или более) строчками текста. Разместите на форме компонент TBitBtn и задайте ему достаточно длинный заголовок. Не волнуйтесь о том, что такой длинный заголовок "раздувает" кнопку налево и направо. Создайте обработчик формы OnCreate как показано ниже:

VAR
R : TRect;
N : Integer;
Buff : ARRAY[0..255] OF Char;
...    WITH BitBtn1 DO
BEGIN
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;

Теперь у вас есть замечательная кнопка, которая научилась переносить текст!

- Neil [000636]


Delphi 1

Кнопка с несколькими строчками текста II

Я создал удобный компонент, инкапсулирующий обычную кнопку, но с возможностью многострочного заголовка. В *действительности* - это TBitBtn, чей Glyph *нарисован* в виде заголовка с переносом текста. Реальный заголовок невидим. Это работает! Попробуйте с этим поэкспериментировать и сообщите мне о ваших новых находках. Я был удивлен, что это свойство оказалось легко *подавить*. Тем более, что это свойство public/published, а не какой-то кот в мешке. Все это так, но вы можете перекрыть свойство другим с таким же именем и с атрибутом READ ONLY. И вы можете ссылать на свойство предка, как, например, "Inherited Glyph". ООП!

- Neil Rubenking

unit C_wrapb;

interface

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

type
TWrapBtn = class(TBitBtn)
private
{ Private declarations }
FUNCTION GetGlyph: String;
function GetMargin: Integer;
function GetSpacing: Integer;
function GetKind: TBitBtnKind;
function GetLayout: TButtonLayout;
function GetNumGlyphs: TNumGlyphs;
procedure CMTextChanged(var Message: TMessage);
message CM_TEXTCHANGED;
procedure CMFontChanged(var Message: TMessage);
message CM_FONTCHANGED;
procedure WMSize(var Msg: TWMSize);
message WM_SIZE;
procedure CaptionGlyph;
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
Property Glyph: String Read GetGlyph;
Property Margin: Integer Read GetMargin;
property Spacing: Integer Read GetSpacing;
property Kind: TBitBtnKind Read GetKind;
property Layout: TButtonLayout Read GetLayout;
property NumGlyphs: TNumGlyphs Read GetNumGlyphs;
end;

procedure Register;

implementation

procedure TWrapBtn.CaptionGlyph;
VAR
GP  : TBitmap;
R   : TRect;
Buff: ARRAY[0..255] OF Char;
begin
GP := TBitmap.Create;
try
WITH GP DO
BEGIN
Canvas.Font := Self.Font;
StrPCopy(Buff, Caption);
Inherited Margin := 0;
Inherited Spacing := GetSpacing;
Width := Self.Width - GetSpacing;
Height := Self.Height - GetSpacing;
R := Bounds(0,0,Width,0);
DrawText(Canvas.Handle, Buff, StrLen(Buff), R,
DT_CENTER OR DT_WORDBREAK OR DT_CALCRECT);
OffsetRect(R, (Width-R.Right) DIV 2,
(Height - R.Bottom) DIV 2);
DrawText(Canvas.Handle, Buff, StrLen(Buff), R,
DT_CENTER OR DT_WORDBREAK);
END;
Inherited Glyph := GP;
Inherited NumGlyphs := 1;
finally
GP.Free;
end;
end;

FUNCTION TWrapBtn.GetGlyph: String;
BEGIN
Result := '(Н/Д)';
END;

procedure TWrapBtn.CMTextChanged(var Message: TMessage);
begin
Inherited;
CaptionGlyph;
end;

procedure TWrapBtn.CMFontChanged(var Message: TMessage);
begin
Inherited;
CaptionGlyph;
end;

procedure TWrapBtn.WMSize(var Msg: TWMSize);
begin
Inherited;
CaptionGlyph;
end;

function TWrapBtn.GetMargin: Integer;
begin
Result := 0;
end;

function TWrapBtn.GetSpacing: Integer;
begin
{$IFDEF Win32}
Result := 12;
{$ELSE}
Result := 6;
{$ENDIF}
end;

function TWrapBtn.GetKind: TBitBtnKind;
BEGIN
Result := bkCustom;
END;

function TWrapBtn.GetLayout: TButtonLayout;
begin
Result := blGlyphLeft;
end;

function TWrapBtn.GetNumGlyphs: TNumGlyphs;
begin
Result := 1;
end;

procedure Register;
begin
RegisterComponents('FAQ', [TWrapBtn]);
end;

end.

[000722]


Альтернатива кнопкам в Delphi

Alex Polyanskiy пишет:

Вместо компонентов TButton, TBitBtn и т.д. можно исвользовать компоненты TImage расположив их по 2 или по 3 один над одним, в них помещаются рисунки заменяющие кнопки
1- простое изображение
2- подсвеченное изображение
3- имитирующее нажатие

свойству 2 и 3 компонентов Visible присвоить False;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Image1.Visible:=False;//При наведении указателя мыши появляется второе изображение
Image2.Visible:=True;
end;

procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image2.Visible:=False;// При нажати ЛКМ пояпляется третье изображение
Image3.Visible:=True;
end;

procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image2.Visible:=False;//При отпускании ЛКМ активизируется подсвеченное изображение
Image3.Visible:=True;
end;

И вконце при перемещении указателя манипулятора на форму активизация первого изображения

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Image2.Visible:=False;
Image3.Visible:=False;
Image1.Visible:=True;
end;

[000969]


Нажатие кнопки

Я знаю как нажать кнопку через keypress, но хотя пользователь определил действие в обработчике события OnClick, сама кнопка не отражает видимых изменений, происходящих при ее нажатии мышью. Кто-нибудь может мне помочь?

Вы можете сделать кнопку "нажатой" или "ненажатой", посылая ей сообщение BM_SETSTATE. Определить ее текущее состояние можно, послав ей сообщение BM_GETSTATE.

Для нажатия кнопки:

Button1.Perform( BM_SETSTATE, 1, 0 );

Для отжатия кнопки:

Button1.Perform( BM_SETSTATE, 0, 0 );

Чтобы обнаружить нажатие кнопки:

ButtonPressed := Button1.Perform( BM_GETSTATE, 0, 0 ) = 1;

- Ed Jordan [000996]


Delphi 1

Программное открытие ComboBox

Используйте недокументированное свойство DroppedDown:

MyComboBox.DroppedDown := True;

Или:

MyComboBox.Perform(CB_SHOWDROPDOWN, True, 0);

[000511]


Заполнение TDBComboBox/ListBox

Как заполнить TDBComboBox и TDBListBox

Большинство Delphi-компонентов для работы с базами данных заполняются сами после того, как прилинкованный набор данных будет открыт. Тем не менее, DbListboxs и DbComboboxs не поддерживают данную характеристику. Данные два компонента не предназначены для отображения вашего набора данных, но тем не менее, они заполняются на основе полученных данных. Использование этих компонентов является прямым форвардом. При обновлении вашей таблицы, значения DbListbox и DbCombobox будут поститься в соответствующее поле.

Заполняются DbCombobox и DbListbox точно также, как и обычные ComboBox и ListBox. Строки текста в ListBox и ComboBox представляют собой список TString. Данный список у наших компонентов хранится в свойстве "Items". При добавлении новых строк к списку используется метод "Add". Если вы хотите использовать другой тип данных, не String, то он должен быть преобразован во время выполнения программы. Если в конце списка имеется пустая строка, рекомендуем установить свойство "IntegralHeight" в True.

Заполнение DbListbox четырьмя строками программным путем могло бы выглядеть примерно так:

DbListbox1.items.add('первая строка');
DbListbox1.items.add('вторая строка');
DbListbox1.items.add('третья строка');
DbListbox1.items.add('четвертая строка');

Заполнение DbListbox во время разработки требует использования Инспектора Объектов. Двойной щелчок на свойстве компонента "Items" позволит вызвать "String List Editor" (редактор списка строк) и ввести необходимые строки.

К сожалению, если заполнять данным способом ComboBox, значение по умолчанию отсутствует. Данный результат возможен при установке свойства DbCombobox "text". (свойство "text" не доступно в Инспекторе Объектов, оно должно быть установлено программным путем). Установка значения по умолчанию для первого значения в DbCombobox должна выглядеть примерно таким образом:

DbCombobox1.text := DbCombobox1.items[0];

Часто полезным бывает заполнить DBListBox из набора данных. Это может быть сделано с помощью цикла:

procedure TForm1.FormCreate(Sender: TObject);
begin
with table2 do begin
open;
while not EOF do
begin
DBlistbox1.items.add(FieldByName('name').AsString);
next;
end;
end;
end;

[000846]


Ошибка в TDBComboBox или особенность работы?

Форма предназначена для ввода новой информации и работает с двумя таблицами – master и detail. Необходимо, чтобы все компоненты формы (DBEdit, DBComboBox) при открытии отображали пустые строки. Информация из таблицы детализации содержится в DBComboBox. Список создается стандартным способом - DBComboBox.Items.Add(Fields[1].AsString. Если DBComboBox.ItemIndex := -1, то должна отображаться пустая строка. При открытии формы в DBComboBox отображается информация последней записи таблицы детализации. Почему последняя строка– надеюсь понятно. Если заменить в процедуре инициализации списка DBComboBox.ItemIndex := -1 на DBComboBox.Text := ''; то появляется другая странность: Пользователь раскрывает список и, ничего не выбрав, переходит на другой компонент – в DBComboBox вновь появляется информация последней записи таблицы детализации. Исправить это поведение DBComboBox можно так - если в модуле DBCTRLS.PAS изменить SetComboText:

procedure TDBComboBox.SetComboText(const Value: string);
var
I: Integer;
Redraw: Boolean;
begin
if Value <> GetComboText then
begin
if Style <> csDropDown then
begin
Redraw := (Style <> csSimple) and HandleAllocated;
if Redraw then SendMessage(Handle, WM_SETREDRAW, 0, 0);
try
//------ ADD --------------------------------------------------------------------------------
if ItemIndex = -1 then
begin
Text := '';
Exit;
end;
//----------------------------------------------------------------------------------------------
if Value = '' then I := -1 else I := Items.IndexOf(Value);
ItemIndex := I;
finally
if Redraw then
begin
SendMessage(Handle, WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
if I >= 0 then Exit;
end;
if Style in [csDropDown, csSimple] then Text := Value;
end;
end;

После этого откомпилировать модуль DBCTRLS.PAS и заменить старый. Но может быть есть другие варианты.

С уважением, VS. [000911]


Различные цвета строк в DBCtrlGrid

Кто-нибудь знает как установить другие цвета для строк DBCtrlGrid?

Используйте событие drawColumnCell. И не забудьте выставить defautlDrawing в False

procedure TMain.ProjectGridDrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
projectGrid.canvas.brush.color := clWindow;
projectGrid.canvas.fillRect(rect);
if gdSelected  in state then
begin
projectGrid.canvas.brush.color := clHighlight;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clHighlightText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clHighlightText;
end
else if gdFocused in state then
begin
projectGrid.canvas.brush.color := clWindow;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clWindowText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clWindowText;
end
else if gdFixed in state then
begin
projectGrid.canvas.brush.color := clHighlight;
if fsBold in projectGrid.canvas.font.style then
begin
projectGrid.canvas.font.color := clHighlightText;
projectGrid.canvas.font.style := [fsBold];
end
else
projectGrid.canvas.font.color := clHighlightText;
end;
with globalDataModule.qProjects do
begin
// тестовая запись. Устанавливаем свойства для перекрытия заданных по умолчанию;
if fieldByName('EST_COMPL_DATE').asDateTime < date then
projectgrid.Canvas.font.color := clRed;
if compareStr(fieldByName('STAT_CODE').asString, 'HD') = 0 then
projectgrid.Canvas.font.color := clOlive;
if  (compareStr(fieldByName('CHANGED').asString, 'Y') = 0) and
(fieldByName('ASSIGN_EMP_ID').asInteger = userRecord.UserId) then
projectgrid.Canvas.font.style := [fsBold];
end;
projectGrid.canvas.textOut(rect.left+2, rect.top+2, column.field.text);
end;
[000296]


Одной строкой

Перевод в верхний регистр первого вводимого символа

procedure TForm1.DBEdit1KeyPress(Sender: TObject; var Key: Char); begin
if (DBEdit1.SelStart = 0 ) then
Key := upCase(Key) ; end;

Или для Edit:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
with Sender as TEdit do
if (Text = '')
or (Text[SelStart] = ' ')
or (SelLength = Length(Text)) then
if Key in ['a'..'z'] then  Key := UpCase(Key);
end;

[000417]


Delphi 1

Преобразование TEdit в TDBEdit

Предположим вы захотели заменить Edit на DBEdit:

  • Выберите в дизайнере формы компонент Edit и нажмите Ctrl+X для перемещения его в буфер обмена.
  • Переключитесь в редактор кода, перейдите в самый конец модуля (там, где "End.") и вставьте (Ctrl+V) то, что у вас хранится в буфере обмена - в коде появится текстовое описание компонента.
  • В первой строчке замените "TEdit" на "TDBEdit". Переместите описание в буфер обмена и вставьте это на форму. Оooпс! Delphi ругнулся, потому что TDBEdit не имеет свойство Text. Возвращайтесь обратно на форму и снова вставьте компонент. Удалите строку со свойством Text, переместите описание компонента в буфер обмена и вставьте его обратно на форму.
Это решение в общих чертах решает проблему замены компонентов разного типа. Довольно часто встречаются одно или несколько несовместимых свойств, и при попытке вставить измененный компонент вы получите ошибку. Не волнуйтесь, просто возвратитесь к текстовой версии, удалите проблемное свойство и попробуйте снова.

*** ПРЕДУПРЕЖДЕНИЕ *** Не используйте метод "DFM as text", иначе любое изменение может привести к ошибке (смотри выше), а то и к летальному, для формы, исходу! [000439]


Использование опции MultiSelect в DBGRID

Есть пример в Delphi Technical Information... Его можно посмотреть по адресу

http://loki.borland.com/winbin/bds.exe?getdoc+2976+Delphi

{*
Данный пример позволяет производить множественный выбор записей
в табличной сетке и отображать второе поле
набора данных.

Метод 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;
[000064]


Помещение компонентов в DBGrid

В: Как мне поместить компоненты в TDBGrid?

О: Я знаю как это сделать, и это нечто!

Как поместить компоненты в 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;

Самое интересное место - последний участок кода. Он выполняется в случае, когда состояние не равно 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. Я все время сталкиваюсь с данной проблемой, да и не только я, судя по новостным конференциям. Данная опция действует в случае потери компонентом фокуса и отменяет последние результаты редактирования. Во всяком случае во всех моих проектах я первым делом сбрасываю данный флаг.

[000065]


Сортировка колонок в DBGrid

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

Главное препятствие в решении задачи - сам 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; (* WITH Headercontrol1.Sections *)
try (* except *)
{ Используем индексы с тем же именем, что и имя поля }
(DataSource1.Dataset as TTable).IndexName := TheFn;   { Пробуем задать имя индекса }
except
HeaderControl1.Sections.Items[a].AllowClick := False; { Индекс недоступен }
end; (* EXCEPT *)
END; (* FOR *)
END; (* PROCEDURE *)

Используйте свойство FieldName компонента DBGrid для задания индекса с тем же именем, что и имя поля.

procedure TfrmDoc.HeaderControl1SectionClick(HeaderControl: THeaderControl;
Section: THeaderSection);
begin
(DataSource1.Dataset as TTable).IndexName :=
DBGrid1.Columns.Items[ Section.Index - 1 ].FieldName;

 end;
[000066]


Dbgrid с цветными ячейками I

Не знаю, помогу ли я Вам, но я расскажу как можно изменить цвет отдельных ячеек 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; {сохраняем оригинальный цвет}
if Column.FieldName = 'EmpNo' then {"раскрашиваем" ячейки только для поля
EmpNo}
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. [000067]


Delphi 1

Dbgrid с цветными ячейками II

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

Обработайте событие OnDrawDataCell. Вот пример, который использует демонстрационную таблицу COUNTRY и рисует текст красным цветом во всех строках, содержащих страны с населением свыше 10 миллионов человек:

begin
if Table1.FieldByName('Population').AsFloat < 10000000 then
DBGrid1.Canvas.Font.Color := clRed;
dbGrid1.DefaultDrawDataCell(Rect,Field,State);
end;

[000403]


Dbgrid с цветными ячейками III

C цветом ячейки DBGrid не так все просто, ведь в Delphi 1.0 разукрасить ячейку можно в обработчике события OnDrawDataCell, тогда как в Delphi 2.0 вам придется прибегнуть к событию OnDrawColumnCell. Для того чтобы создать код, который бы работал в ОБОИХ версих Delphi, вам необходимо прибегнуть к механизму условной компиляции, с помощью которого вы можете СКРЫТЬ обработчик OnDrawColumnCell в Delphi 1.0 и ВКЛЮЧИТЬ его в Delphi 2.0. Вот пример, в котором все ячейки строки рисуются красным, если колонка 'Preferred' содержит 'True':

...
private
{ Private declarations }
{$IFDEF Win32}
procedure DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
{$ENDIF}
procedure DrawField(const Value: String; const Rect: TRect;
vCanvas: TCanvas; vFont: TFont; vAlignment: TAlignment);
...
procedure TForm1.DrawField(const Value: String; const Rect: TRect;
vCanvas: TCanvas; vFont: TFont; vAlignment: TAlignment);
VAR X : Integer;
BEGIN
vCanvas.Font := vFont;
vCanvas.Font.Color := clRed;
vCanvas.Font.Style := vCanvas.Font.Style + [fsUnderline];
CASE vAlignment OF
taRightJustify : BEGIN
SetTextAlign(vCanvas.Handle, TA_RIGHT);
X := Rect.Right-2;
END;
taLeftJustify  : BEGIN
SetTextAlign(vCanvas.Handle, TA_LEFT);
X := Rect.Left+2;
END;
taCenter       : BEGIN
SetTextAlign(vCanvas.Handle, TA_CENTER);
X := (Rect.Right+Rect.Left) DIV 2;
END;
END;
vCanvas.TextRect(Rect, X, Rect.Top+2, Value);
SetTextAlign(vCanvas.Handle, TA_LEFT);
END;

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
TRect; Field: TField; State: TGridDrawState);
begin
WITH Sender AS TDBGrid, DataSource.DataSet DO
BEGIN
IF FieldByName('Preferred').AsString <> 'True' THEN Exit;
DrawField(Field.DisplayText, Rect, Canvas, Canvas.Font,
Field.Alignment);
END;
end;

{$IFDEF Win32}
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
WITH Sender AS TDBGrid, DataSource.DataSet DO
BEGIN
IF FieldByName('Preferred').AsString <> 'True' THEN Exit;
DrawField(Column.Field.DisplayText, Rect, Canvas,
Column.Font, Column.Alignment);
END;
end;
{$ENDIF}

procedure TForm1.FormCreate(Sender: TObject);
begin
{$IFDEF Win32}
DBGrid1.OnDrawDataCell := NIL;
DBGrid1.OnDrawColumnCell := DBGrid1DrawColumnCell;
{$ENDIF}
end;

- Neil Rubenking [000968]


Показ изображений в DBGrid

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

Код компонента:

{
// DBPICGRD.PAS (C)
//              ВСЕ ПРАВА ЗАЩИЩЕНЫ.
//
//    ОПИСАНИЕ:
//      Компонент DBGrid, способный отображать графику в ячейках.
}

unit DBPicGrd;

interface

uses
DBGrids, DB, DBTables, Grids, WinTypes, Classes, Graphics;

type
TDBPicGrid = class(TDBGrid)
protected
procedure DrawDataCell(const Rect: TRect;
Field: TField; State: TGridDrawState); override;
public
constructor Create(AOwner : TComponent); override;
published
property DefaultDrawing default False;
end;

procedure Register;

implementation

constructor TDBPicGrid.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
DefaultDrawing := False;
end;

procedure TDBPicGrid.DrawDataCell(const Rect: TRect; Field: TField;
State: TGridDrawState);
var
bmp : TBitmap;
begin
with Canvas do
begin
FillRect(Rect);
if Field is TGraphicField then
try
bmp := TBitmap.Create;
bmp.Assign(Field);
Draw(Rect.Left, Rect.Top, bmp);
finally
bmp.Free;
end
else
TextOut(Rect.Left, Rect.Top, Field.Text);
end;
end;

procedure Register;
begin
RegisterComponents('Custom', [TDBPicGrid]);
end;

end.
[000068]


Модуль Db_QBF.PAS, позволяющий в Delphi осуществить форму запроса для компонентов DbGrid

Предлагаю Вашему вниманию модуль Delphi для модального диалога, поддерживающий форму запроса (Query By Form - QBF) для компонентов DbGrid с возможностью получения данных от Table-компонентов (не используя Query-компонентов).

Встроенные характеристики обмена данными в Delphi делают эту задачу намного труднее, чем, например, в таких ресурсоемких инструментальных средствах, как Oracle Forms (Оракловые формы). Данный модуль не такой мощный как встроенные QBF-возможности Оракловых форм, но он заполняет значительную брешь в функциональности Delphi.

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

unit Db_QBF; { Форма запроса базы данных }

{ Все права защищены. Автор Rick Rutt.
Данный модуль может без какой-либо оплаты быть использован в программе,
скопирован или распространен любым человеком и для любой цели, если все
копии данного модуля сохраняют это авторское уведомление.
Автор предоставляет разрешение каждому для создания производного кода, если
каждая производная работа содержит авторское уведомление и строку
"Части данной работы основываются на Db_QBF.PAS, созданным Rick Rutt."
}

{ Данный модуль обеспечивает простую, но эффективную форму запроса
для доступа приложений к базам данных, используя Borland Delphi.
Данный модуль также располагает сервисом Sort By Form (форма сортировки).

Форма запроса отображает модальное диалоговое окно с компонентом StringGrid,
содержащим искомые поля, полученные при вызове DbGrid. Пользователь может
ввести точную величину поиска для любого количества полей и использовать
функцию drag and drop (перетащи и брось) для изменения порядка сортировки полей.
(Только тех полей, которые содержат искомые величины, влияющие на сортировку.)
Когда пользователь щелкает в диалоговом окне на кнопку OK, данный модуль модифицирует
значение свойства IndexFieldNames компонента DbGrid, применяет диапазон поиска
(точные величины), и обновляет данные.
В случае, если пользователь не указывает ни одной из величин поиска, данный модуль очищает
значение свойства IndexFieldNames компонента DbGrid, очищает диапазон поиска
и обновляет данные.

Сервис Sort By Form работает аналогично, за исключением того,
что не принимает в расчет величину поиска, введенную пользователем. Пользователь пользуется функцией drag and drop (перетащи и брось)
для установления порядка сортировки и затем нажимает на кнопку OK. Данный модуль модифицирует
значение свойства IndexFieldNames компонента DbGrid, очищает диапазон поиска
и обновляет данные.
}

{ Создайте соответствуюшую форму диалога, используя меню "File/New.../Dialogs"
и выбрав пункт "Standard Dialog Box". Разместите на форме компонент StringGrid
(Вы найдете его в палитре компонентов на странице "Additional").
Установите следующие размеры StringGrid: высота 161 и ширина 305.
И, наконец, замените исходный код новой формы (PAS-файл) данным модулем.
}

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, ExtCtrls, Grids, DBGrids;

{ Следующие две процедуры обеспечивают механизм доступа
сервисов данного модуля.

Кнопка (или пункт меню) вызывают процедуру,
передавая ей в качестве аргумента DbGrid. (Не забудьте добавить строку
"uses Db_QBF;" в секцию реализации модуля вызова форм.)

Ограничение: компонент DbGrid должен ссылаться на DataSource, который, в свою очередь,
ссылается на DataSet, работающий с таблицой. Данный модуль не поддерживает
запрос напрямую к DataSet ввиду отсутствия свойства IndexFieldNames.
}

procedure QueryByForm(grid: TDbGrid);

procedure SortByForm(grid: TDbGrid);

{ Следующая секция управляется средой Delphi. }

type
TdlgQBF = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
gridQBF: TStringGrid;
procedure OKBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
dlgQBF: TdlgQBF;

implementation

{ Следующая секция пишется программистом
с помощью среды Delphi. }

uses Dialogs, Db, DbTables;

{$R *.DFM}

const
qbfRowHeight = 16;
qbfColWidth = 150;

qbfFieldLabel = '<<Поле>>';
qbfValueLabel = '<<Значение>>';

qbfQueryCaption = 'Запрос для таблицы ';
qbfSortCaption = 'Порядок сортировки для таблицы ';

var
{ Объявим некоторые элементы управления, участвующие в QBF-диалоге при нажатии кнопки OK. }
CallingGrid: TDbGrid;
CallingMode: (modeQuery, modeSort);

procedure SetupAndShowForm; { Инициализация формы, обеспечивающей визуализацию работы двух объявленных выше процедур }
var
i, j, n: integer;
tbl: TTable;
f: TField;
begin
n := CallingGrid.FieldCount;
if n <= 0 then begin { Вместо вывода сообщений могут генерится исключительные ситуации }
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF не обнаружил полей',
mtWarning, [mbOK], 0);
end else if CallingGrid.DataSource = NIL then begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF не обнаружил ссылки на DataSource',
mtWarning, [mbOK], 0);
end else if CallingGrid.DataSource.DataSet = NIL then begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный DataSource без ссылки на DataSet',
mtWarning, [mbOK], 0);
end else if not (CallingGrid.DataSource.DataSet is TTable) then begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный DataSource с сылкой на DataSet, не являющийся таблицей.',
mtWarning, [mbOK], 0);
end else with dlgQBF.gridQBF do begin
{ Данные свойства могут быть изменены и в режиме проектирования }
DefaultRowHeight := qbfRowHeight;
Scrollbars := ssVertical;
ColCount := 2; { Для режима сортировки необходимы две пустые колонки }

{ Данные свойства должны быть установлены во время выполнения программы }
RowCount := Succ(n);
Cells[0,0] := qbfFieldLabel;
Options := Options + [goRowMoving];

tbl := TTable(CallingGrid.DataSource.DataSet);

if CallingMode = modeQuery then begin
dlgQBF.Caption := qbfQueryCaption + tbl.TableName;
Cells[1,0] := qbfValueLabel;
Options := Options + [goEditing]; { Позволяем пользователю ввести значение }
DefaultColWidth := qbfColWidth;
end else begin
dlgQBF.Caption := qbfSortCaption + tbl.TableName;
Cells[1,0] := '';  { Ввод "пустышки" для первой, нефункциональной колонки }
Options := Options - [goEditing]; { Убираем возможность редактирования }
DefaultColWidth := (2 * qbfColWidth); { Этим трюком мы помещаем две пустых секции над одной колонкой }
end;

j := 0;  { Фактическое число полей, показываемое пользователю }
for i := 1 to n do begin
f := CallingGrid.Fields[Pred(i)];
if f.DataType in [ftBlob,ftBytes,ftGraphic,ftMemo,ftUnknown,ftVarBytes]
then  RowCount := Pred(RowCount)  { Игнорируем неиндексируемые поля }
else begin
Inc(j);
Cells[0,j] := f.FieldName;
Cells[1,j] := '';  { Сбрасываем искомую величину }
end;
end;

dlgQBF.HelpBtn.Visible := False;  { Помощь, понятно, отсутствует... }
dlgQBF.ShowModal;
end;  { with dlgQBF.gridQBF }
end;

procedure QueryByForm(Grid: TDbGrid);
begin
CallingGrid := Grid;  { Сохраняем для использования при нажатии на кнопку OK }
CallingMode := modeQuery;
SetupAndShowForm;
end;

procedure SortByForm(Grid: TDbGrid);
begin
CallingGrid := Grid;  { Сохраняем для использования при нажатии на кнопку ОК }
CallingMode := modeSort;
SetupAndShowForm;
end;

procedure TdlgQBF.CancelBtnClick(Sender: TObject);
begin
{ Просто прячем диалог, не делая никаких изменений в вызывающем Grid'е. }
dlgQBF.Hide;
end;

procedure TdlgQBF.OKBtnClick(Sender: TObject);
var
flds, sep, val: string;
i, n, nfld: integer;
begin
flds := '';  { Список полей, разделенных ';'. }
sep := '';  { Разделитель ';' ставится после добавления первого поля. }
nfld := 0;   { Количество полей в списке. }

with dlgQBF.gridQBF do begin
n := Pred(RowCount);
if n > 0 then for i := 1 to n do begin
val := Cells[1,i];  { Значение поиска, введенное пользователем (если имеется) }
if (CallingMode = modeSort)
or (val <> '') then begin
flds := flds + sep + Cells[0,i];
sep := ';';
nfld := Succ(nfld);
end;
end;

with CallingGrid.DataSource.DataSet as TTable do begin
IndexFieldNames := flds;
if (CallingMode = modeSort)
or (flds = '') then begin
CancelRange;
end else begin
SetRangeStart;
for i := 1 to n do begin
val := Cells[1,i];
if val <> '' then begin
FieldByName(Cells[0,i]).AsString := val;
end;
end;

SetRangeEnd;  { Устанавливаем конец диапазона так, чтобы он соответствовал его началу }
for i := 1 to n do begin
val := Cells[1,i];
if val <> '' then begin
FieldByName(Cells[0,i]).AsString := val;
end;
end;
ApplyRange;
end;

Refresh;
end;  { with CallingGrid.DataSource.DataSet }
end;  { with dlgQBF.gridQBF }

dlgQBF.Hide;
end;

end.
[000069]


Сохранение и восстановление конфигурации DBGRID

Данный совет рассказывает о возможности сохранения и восстановления порядка колонок после изменения его пользователем (воспользовавшись, например, функцией drag and grop - перетащи и брось).

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

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

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;
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;
[000070]


Изменение размеров DBGrid

У меня есть форма. На ней расположены поле редактирования, компонент SQL Query, DBGrid и кнопка. Я заполняю поле редактирования и при нажатии на кнопку DBGrid отражает результат запроса. Как я могу изменить размер табличной сетки и ее колонок в зависимости от новых значений полей? Поля, возвращаемые запросом, не заполняют всей ширины сетки, а все мои попытки сделать это из кода терпят крах...

Вы можете изменить размер колонки во время выполнения программы, изменяя свойство DisplayWidth соответствующего поля компонента DBGrid...

MyTableMyField.DisplayWidth := Length(MyTableMyField.value);

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

function NewTextWidth(fntFont : TFont; const sString : OpenString) :

integer;
var
fntSave : TFont;
begin
result := 0;
fntSave := Application.MainForm.Font;
Application.MainForm.Font := fntFont;
try
result := Application.MainForm.Canvas.TextWidth(sString);
finally
Application.MainForm.Font := fntSave;
end;
end;

{ вычисляем ширину табличной сетки, которую необходимо отобразить без                 }
{ горизонтальной полосы прокрутки и без дополнительного пространства между последней  }
{ колонкой и вертикальной полосой прокрутки. Свойство Datasource у компонента DBGrid, }
{ как и свойство Dataset у Datasource должны быть назначены заранее,                  }
{ но таблица не должна быть открытой. Примечание: полученная ширина включает ширину   }
{ вертикальной полосы прокрутки, полученной на основе базового режима                 }
{ отображения. Вычисленная ширина полностью занимает рабочую область компонента.      }

function iCalcGridWidth
(
dbg : TDBGrid { корректируемый компонент }
)
: integer; { "точная" ширина }

const
cMEASURE_CHAR   = '0';
iEXTRA_COL_PIX  = 4;
iINDICATOR_WIDE = 11;

var
i, iColumns, iColWidth, iTitleWidth, iCharWidth : integer;
begin
iColumns := 0;
result := GetSystemMetrics(SM_CXVSCROLL);
iCharWidth := NewTextWidth(dbg.Font, cMEASURE_CHAR);
with dbg.dataSource.dataSet do
for i := 0 to FieldCount - 1 do with Fields[i] do
if visible then
begin
iColWidth := iCharWidth * DisplayWidth;
if dgTitles in dbg.Options then
begin
iTitleWidth := NewTextWidth(dbg.TitleFont, DisplayLabel);
if iColWidth < iTitleWidth then iColWidth := iTitleWidth;
end;
inc(iColumns, 1);
inc(result, iColWidth + iEXTRA_COL_PIX);
end;
if dgIndicator in dbg.Options then
begin
inc(iColumns, 1);
inc(result, iINDICATOR_WIDE);
end;
if dgColLines in dbg.Options
then inc(result, iColumns)
else inc(result, 1);
end;

Я должен использовать функцию NewTextWidth, а не Canvas.TextWith компонента DBGrid, так как Canvas еще не инициализирован во время вызова iCalcGridWidth.

[000071]


Перемещение из 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.

[000072]


DbGrid и клавиши акселерации

Форма содержит поле TEdit, поле TComboBox, TDBGrid и несколько BitBtn-кнопок (в перечисленном порядке идет и обход компонентов клавишей Tab). Табличная сетка была установлена для выбора целой колонки, и обратной операции при потере фокуса. Некоторым кнопкам были назначены клавиши акселерации путем установки символа "&" в их заголовках. Нажимая <alt> и соответствующую клавишу, ожидаешь соответствующей реакции, но не тут-то было. Беда приходит когда табличная сетка получает фокус.

Все работает превосходно, если вы используете клавиши навигации (например up, down, pgup и др.); тем не менее, если использовать клавиши акселерации (не используя клавишу <alt>), вызникают соответствующие клавишам события onClick. [000329]


Delphi 1

TDBGrid - свойства FixRows & FixCols

Сетки, не предназначенные для работы с данными, имеют свойства FixCols и FixRows, которые не позволяют данным прокручиваться, но эти свойства не были унаследованы TDBGrid.

Обходной путь для TDrawGrid:

TDrawGrid(DBGrid1).FixedCols := 2;

[000330]


Delphi 1

TDBGrid - поддержка одинарного щелчка

Есть какой-либо способ отследить событие одинарного щелчка на компоненте TDBGrid?

Нет. Вы должны взять объект, поддерживающий данное событие (типа tStringGrid) и добавить поддержку данных (смотри главу 12 руководства по созданию компонентов), или взять tDBGrid и добавить событие OnMouseDown (смотри главу 4 руководства по созданию компонентов). [000331]


Delphi 1

Эксперт создания таблиц

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

Да, это известная проблема. [000334]


Delphi 1

Работа с несколькими записями

DBGrid не отображает графические поля. Тем не менее вы можете решить эту задачу программным путем. Один из методов заключается в следующем: на форме располагаются несколько компонентов TTable со ссылкой на одну и ту же таблицу, и несколько компонентов DBImage, связанные с компонентами TTable. Основная идея заключается в синхронизации позиции курсора, управляемым пользователем. Для этого мы применим компонент DBNavigator, который заботится о перемещении в первую таблицу и запишем код для обработчика события навигатора OnClick для позиционирования указателя записи для других объектов. Для воссоздания примера выполните следующее:

  1. Расположите на форме три компонента TTable с именами Table1, Table2, и Table3 соответственно
  2. Расположите на форме три компонента DataSources и свяжите их с Table1..Table3
  3. Расположите на форме три компонента DBImage и свяжите их с DataSource1..DataSource3, все они будут иметь одно и тоже значение свойства DataField.
  4. Расположите на форме компонент DBNavigator и свяжите его с DataSource1.
  5. Создайте процедуру как показано ниже:

    procedure InitPosition ;
    begin
    { Начальная позиция }
    Form1.Table2.Active := TRUE ;
    Form1.Table3.Active := TRUE ;
    if Form1.Table1.RecordCount > 1 then Form1.Table2.MoveBy(1) ;
    if Form1.Table2.RecordCount > 2 then Form1.Table3.MoveBy(2) ;
    end ;

  6. В обработчике события Form.OnShow вызовите InitPosition.
  7. В обработчике события OnClick компонента DBNavigator создайте следующий код:
    procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
    begin
    case button of
    nbNext :
    begin
    if not Table2.Eof then Table2.Next ;
    if Table2.Eof then Table2.Active := FALSE ;
    if not Table3.Eof then Table3.Next ;
    if Table3.Eof then Table3.Active := FALSE ;
    end ;
    nbPrior :
    begin
    if not Table2.Bof then Table2.Prior ;
    if not Table3.Bof then Table3.Prior ;
    end ;
    nbFirst :
    InitPosition ;
    nbLast :
    begin
    Table2.Active := FALSE;
    Table3.Active := FALSE;
    end ;
    end ;
    end;

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

OAmiry/Borland [000371]


Одной строкой

Предохранение от автодобавления записи

Мне необходимо как-то предотвратить автоматическое добавление записей в таблицу. Может быть предусмотреть какую-то хитрость для создания новой записи в табличной сетке?

Попробуй это (я правда оставил некоторый мусор после испытаний кодов клавиш). Для DBGridkeydown используй:

begin
s := 'ASCII код клавиши ' + IntToStr(Ord(key)) +
' десятичное';
{showmessage(s);}
s :=IntToStr(Ord(key));
end;

И затем в TTable сделайте следующее:

begin
if
s<>'45' then
raise Eabort.create('');
s:='';
end;

Естественно, "s" должна быть объявлена глобально.

Bill Curtis
Borland International [000378]


Delphi 1

Перехват события компонента DBGrid MouseDown

...вот совпадение. Я потолько что отвечал на другой вопрос, где меня также спрашивали как перехватить событие DBGrid MouseDown:

Вам необходимо создать класс-наследник TDBGrid и перекрыть процедуру MouseDown. Вот код, который реально работает у меня:

TMyDBGrid = class(TDBGrid)
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
end;

procedure TMyDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);

{ Здесь делайте что хотите, можете погудеть в системный рожок }
MessageBeep(mb_Ok);
end;

--------- покоцано --------------

unit MyDBGrid;

interface

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

type
TMyDBGrid = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
{ Public declarations }
published
{ Published declarations }
property OnMouseDown;
end;

procedure Register;

implementation

procedure TMyDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
FOnMouseDown: TMouseEvent;
begin
inherited MouseDown(Button, Shift, X, Y);
FOnMouseDown := OnMouseDown;
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
end;

[000411]


Delphi 1

Использование 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;

[000536]


Delphi 1

DBGrid c FixedCols

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

Я делаю это таким образом:

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

Cheers [000569]


Delphi 1

Обновление вычисляемых полей в DBGrid

Разместите строчку типа нижеприведенной в конце кода обработчика события OnCalcFields:

{предположим, что вы используете DBGrid1}
if DBGrid1.Showing then DBGrid1.Invalidate ;

OAmiry/Borland [000571]


Delphi 1

Рисование текста в DBGrid I

Следующий метод может быть использован в качестве обработчика события 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;

[000591]


Delphi 1

Рисование текста в DBGrid II

Для отображения таблицы я использую 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.

Eryk [000673]


Delphi 1

Симуляция нажатия кнопки при наличии 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 ;

OAmiry/Borland [000608]


Delphi 1

DBGrid без вертикальной полосы прокрутки

Удаление вертикальной полосы прокрутки у TDBGrid

Для удаления вертикальной полосы прокрутки из компонента TDBGrid, вам необходимо перекрыть метод Paint. Внутри метода Paint вам необходимо вызвать процедуру API SetScrollRange, чтобы установить минимальные и максимальные значения полосы прокрутки в ноль (это запретит вывод полосы прокрутки), после чего вызвать родительский метод Paint. Код, приведенный ниже - новый компонент, названный TNoVertScrollDBGrid, у которого отсутствует вертикальная полоса прокрутки. Вы можете скопировать этот код в файл с именем NEWGRID.PAS и добавить данный компонент в палитру компонентов.

unit Newgrid;

interface

uses
WinTypes, WinProcs, Classes, DBGrids;

type
TNoVertScrollDBGrid = class(TDBGrid)
protected
procedure Paint; override;
end;

procedure Register;

implementation

procedure TNoVertScrollDBGrid.Paint;
begin
SetScrollRange(Self.Handle, SB_VERT, 0, 0, False);
inherited Paint;
end;

procedure Register;
begin
RegisterComponents('Data Controls', [TNoVertScrollDBGrid]);
end;
end.

[000629]


Delphi 1

Многострочный DBGrid

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

Я добавил дополнительное свойство LinesPerRow. Установка значений данного свойства соответственно изменяет высоту строки, в зависимости от текущего шрифта. Текст в ячейках будет переноситься, если значение LinesPerRow больше чем единица. Все это произведение искусств оказалось чрезвычайно полезным и удивительно простым, так что я публикую его здесь в надежде, что оно пригодится кому-нибудь еще. Код простой, но для его понимания необходимо изучение исходного кода VCL.

Я протестировал данный код и он отлично работал. Небольшая доводка все-же нужна (обработка blob-полей, обработка ошибок и пр.), но это не сложно.

unit Dbmygrid;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, DB, DBTables, StdCtrls, ExtCtrls, Grids, DBGrids;

type
TMultiLineDBGrid = class(TDBGrid)
private
FLinesPerRow: Integer;
procedure  DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState);
procedure  LayoutChanged; override;
procedure SetLinesPerRow(ALinesPerRow: Integer);
public
property LinesPerRow: Integer read FLinesPerRow write SetLinesPerRow default 1;
constructor Create(AOwner: TComponent); override;
end;

implementation

constructor TMultiLineDBGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FLinesPerRow := 1;
OnDrawDataCell := DrawDataCell;
end;

procedure TMultiLineDBGrid.LayOutChanged;
begin
inherited LayOutChanged;
DefaultRowHeight := DefaultRowHeight * LinesPerRow;
end;

procedure  TMultiLineDBGrid.DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState);
var
Format: Word;
C: array[0..255] of Char;
begin
if LinesPerRow = 1 then
Format := DT_SINGLELINE or DT_LEFT
else
Format  :=  DT_LEFT or DT_WORDBREAK;

Canvas.FillRect(Rect);

StrPCopy(C, Field.AsString);
WinProcs.DrawText(Canvas.Handle, C, StrLen(C), Rect, Format);
end;

procedure TMultiLineDBGrid.SetLinesPerRow(ALinesPerRow: Integer);
begin
if ALinesPerRow <> FLinesPerRow then
begin
FLinesPerRow := ALinesPerRow;
LayoutChanged;
end;
end;

end.

Chris Hall [000668]


Delphi 1

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;

[000676]


Delphi 1

TDBGrid 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, то мы добились того, чего хотели.

Kurt Barthelmess [000740]


Delphi 1

TDBGrid с номером строки и пр.

Скомпилируйте это, и вы получите новый компонент с нужными свойствами:

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;

- Mark Meyer [000813]


Копирование информации из 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.

Замечания:

Я привожу только сомнительную часть. Мои комментарии отмечены {AK:}

//как в простой текстовый редактор, так и в Excell
{AK: Excel - с одной L на конце}
...
dbg.Visible := False;  // Делаем грид невидимым, чтобы не тратилось время
// на его перерисовку при прокрутке DataSet - просто и
// эффективно
{AK: Вот изврат, который сразу бросается в глаза. Для это предназначены методы EnableControls/DisableControls датасета!}
 bm := dbg.DataSource.DataSet.GetBookmark; // для того чтобы не
// потерять текущую запись
{ АК: насколько я помню, сами борланоиды не рекомендовали пользоваться Get/SetBookmark и использовать вместо них свойство BookMark }

Удачи!
Алексей Коган

Примечание (В.О.): вот так советы превращаются в споры и дискуссии, а то и в форумы между читателями :-) [000887]


Буфер обмена и ячейки DBGrid-а

Каким образом возможно вырезать/копировать/вставить ячейку компонента dbGrid или stringGrid?

Внутренний (in-place) редактор является защищенным свойством TCustomGrid, поэтому тут придется немного поколдовать. Вы можете сделать приблизительно так:

type
TMyCustomGrid = class(TCustomGrid)
public
property InplaceEditor;
end;

...

if ActiveControl is TCustomGrid then
TMyCustomGrid(ActiveControl).InplaceEditor.CopyToClipboard;

-Steve Schafer [000906]


Текстовое содержимое ячейки DBGrid

Я не нахожу никакого метода получения текстового значения ячейки сетки, кроме как назначения TField...

Вы можете сделать это с помощью простого наследника TDBGrid:

type
TMyGrid = class(TDBGrid)
public
property InPlaceEditor;
end;

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

Label1.Caption := DBGrid1.InPlaceEditor.Text;

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

- Eryk Bottomley [000957]


Delphi 2

Dbgrid - выбранные строки

Тема: TDBGrid - Selected Rows (выбранные строки)
От: Nancy Reid 72056,212
К: Nancy Reid 72056,212

Существует одно свойство, не упомянутое в файлах помощи (оплошность, господа программисты из 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;

- Nancy Reid [000970]


Delphi 2

Показываемое DBLookupComboBox значение

Cледующая строка в обработчике события OnActivate:

DBLookupCombox1.Perform(WM_KeyDown,38,0);

заполняет показываемое в dblookupcombox значение. Вы посылаете сообщение индекса непосредственно в dblookupcombox.

- Michael Pratt [000971]


Delphi 1

Проблема хранения TDBImage

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

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

Все это потребует от вас изменений в исходном коде VCL, конкретно - в модуле DBCTRLS.PAS. Затем, естественно, это необходимо перекомпилить и пересобрать:

procedure TDBImage.PasteFromClipboard;
var
ClipBrdBmp: TBitmap;
begin
ClipBrdBmp := TBitmap.Create;
if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
begin
ClipBrdBmp.Assign(Clipboard);
Picture.Assign(ClipBrdBmp);
end;
ClipBrdBmp.Free;
end;

Это все. Проблема решена.

- Steve Flynn [000869]


Delphi 1

Копирование текста DBMemo

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

procedure TForm1.Button1Click(Sender: TObject);
var I: integer;
StringList: TStringList;
begin
StringList := TStringList.Create;
try
StringList.Assign(Table1Memo);
for I := 0 to StringList.Count-1 do
writeln(StringList[I])
finally
StringList.Free
end
end;

[000374]


Delphi 2

TDBMemo в TDBCtrlGrid?

Из-за непонятных причин, компоненты TDBImage и TDBMemo не могут быть размещены в DBCtrlGrid.

Обойти данное препятствие можно путем создания наследника TDBImage (или TDBMemo), позволяющего его помещать в DBCtrlGrid. Перекройте конструктор Create следующим образом:

constructor TMYDBImage.Create(AOwner:TComponent);
begin
inherited Create(AOWner);
ControlStyle := ControlStyle + [csReplicatable];
end;

- Pat Ritchey [000900]


Пример KeyDown компонента DBNavigator

"Dmitry" <dimon@diogen.nstu.nsk.su>

Есть некоторое решение для создания "горячих клавиш" в DBNavigator. Установите свойство TForm.KeyPreview в TRUE и напишите обработчик события onkeydown. Примерно так:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
(* Классный участок кода от Graphical Gnome *)
KeyBtn: array[TNavigateBtn] of record
Key: Word;
Btn: TNavigateBtn;
end = (
(Key: VK_F1; Btn: nbFirst),
(Key: VK_F2; Btn: nbPrior),
(Key: VK_F3; Btn: nbNext),
(Key: VK_F4; Btn: nbLast),
(Key: VK_F5; Btn: nbInsert),
(Key: VK_F6; Btn: nbDelete),
(Key: VK_F7; Btn: nbEdit),
(Key: VK_F8; Btn: nbPost),
(Key: VK_F9; Btn: nbCancel),
(Key: VK_F10; Btn: nbRefresh)
);
var
i: TNavigateBtn;
begin
for i := nbFirst to nbRefresh do
if KeyBtn[i].Key = Key then begin
DBNavigator1.BtnClick(KeyBtn[i].Btn);
Exit;
end;
end;
[000145]


Delphi 1

Вызов кнопок DBNavigator

Я думаю для этого отлично подойдет вызов public-метода BtnClick(nbButton). Я догадываюсь, почему они не назвали его просто "Click", поскольку это метод события OnClick :-) .

Я делаю приблизительно так:

DBNavigator1.BtnClick(nbInsert);

Это автоматически переключит таблицу в режим Insert, как будто была нажата соответствующая кнопка DBNavigator.

Я не знаю, задокументирована эта "фича", рекомендована ли для таких случаев... Просто у меня это работает и я этим пользуюсь. [000499]


Delphi 1

Свойства кнопок 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 активизирована') ;

[000553]


Delphi 1

DBNavigator без иконок

Я хочу создать 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;

Ralph Friedman [000752]


Delphi 1

Событие OnChange компонента DBRadioGroup

Событие OnChange не возникает, если свойство Values компонента DBRadioGroup изменяется в результате щелчка мышью на кнопке.

Событие OnChange не возникает даже тогда, когда при помощи мыши я пытаюсь изменить значение компонента и переместить фокус на другое поле TDBEdit, расположенное на той же форме. Это наверняка ошибка (BUG). Почему изменение величины мышью обрабатывается иначе, чем при использовании клавиатуры? По аналогии с TDBLookupCombo, в чем разница между щелчком мьшью на выпадающем списке (чье событие OnChange возникает мгновенно) и щелчком на радиокнопке в DBRadioGroup? [000333]


Delphi 1

Пример TDrawGrid Drawcell

procedure TForm1.DrawGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
VAR vRow, vCol : LongInt;
begin
vRow := Row; vCol := Col;
WITH Sender AS TDrawGrid, Canvas DO
BEGIN
IF (vRow=0) OR (vCol=0) THEN
Font.Color := clBlack
ELSE Font.Color := clRed;
TextRect(Rect, Rect.Left, Rect.Top, Format('(%d,%d)',[vRow, vCol]));
END;
end;

- Neil [000512]


Автоматический формат даты в компоненте Edit

PROCEDURE TForm1.Edit1Exit(Sender: TObject);
BEGIN
IF Edit1.Text<>'' THEN BEGIN
TRY
StrToDate(Edit1.Text);
EXCEPT
Edit1.SetFocus;
MessageBeep(0);
raise Exception.Create('"'+Edit1.Text
+'" - некорректная дата');
END{try};
Edit1.Text:=DateToStr(StrToDate(Edit1.Text));
END{if};
END;
[000015]


Массив Edit-компонентов
Procedure DoSomethingWithEditControls;
Var K: Integer;
EditArray: Array[0..99] of Tedit;
begin
Try
For K:= 0 to 99 do
begin
EditArray[K]:= TEdit.Create(Self);
EditArray[K].Parent:= Self;
SetSomeOtherPropertiesOfTEdit; {Устанавливаем необходимые свойства TEdit}
Left:= 100; Top:= K*10;
OnMouseMove:= WhatToDoWhenMouseIsMoved; {Что-то делаем при перемещении мыши}
end;
DoWhateverYouWantToDoWithTheseEdits; {Делаем все что хотим с полученным массивом Edit-компонентов}
Finally
For K:= 0 to 99 do EditArray[K].Free;
end;

Примечание: узнать доступные свойства компонента можно непосредственно в инспекторе объектов и (или) в текстовом режиме вашей формы (щелкните на форме правой кнопкой мыши и выберите пункт View as Text)
[000043]


Delphi 1

Расположение текста в правой части TEdit

Есть какое-нибудь простое решение для расположения текста в правой части TEDIT?

Вместо этого используйте однострочный TMemo. WordWrap=False, WantReturns=False. [000421]


Одной строкой

Ограничение TEdit на ввод не-цифровой информации

Вставьте следующую строку в обработчик события KeyPress:

if not (Key in [#8,'0'..'9']) then Key := #0;
[000501]


Хитрый TEdit

Приведу письмо читателя:

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

unit HintEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
THintEdit = class(TCustomEdit)
private
{ Private declarations }
FHintList:TStrings;
Searching,
CanSearch:boolean;
CurSPos:integer;
protected
{ Protected declarations }
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
property HintList:TStrings read FHintList write FHintList;
destructor Destroy; override;
published
{ Published declarations }
property Anchors;
property AutoSelect;
property AutoSize;
property BiDiMode;
property BorderStyle;
property CharCase;
property Color;
property Constraints;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property ImeMode;
property ImeName;
property MaxLength;
property OEMConvert;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PasswordChar;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property TabStop;
property Text;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
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;

implementation

{$R *.DCR}

procedure Register;
begin
RegisterComponents('Netscape', [THintEdit]);
end;

constructor THintEdit.Create;
begin
inherited;
FHintList:=TStringList.Create;
Searching:=false;
CanSearch:=true;
CurSPos:=-1;
end;

procedure THintEdit.Change;
var
i,l:integer;
begin
if Searching then Exit;
if not CanSearch then Exit;
if Text='' then exit;
l:=Length(Text);
for i:=0 to FHintList.Count-1 do
if Copy(FHintList[i],1,l)=Text then begin
Searching:=true;
CurSPos:=i;
Text:=FHintList[i];
Searching:=false;
SelStart:=Length(Text);
SelLength:=-(Length(Text)-l);
break;
end;
inherited;
end;

procedure THintEdit.KeyDown;
var
l:integer;
begin
if Chr(Key) in ['A'..'z','А'..'Я','а'..'я'] then CanSearch:=true
else CanSearch:=false;
case Key of
VK_DOWN:begin
if (CurSPos<HintList.Count-1) and (SelLength>0) then
if Copy(FHintList[CurSPos+1],1,SelStart)=Copy(Text,1,SelStart) then begin
l:=SelStart;
Inc(CurSPos);
Text:=FHintList[CurSPos];
SelStart:=Length(Text);
SelLength:=-(Length(Text)-l);
end;
Key:=VK_RETURN;
end;
VK_UP:begin
if (CurSPos>0) and (SelLength>0) then
if Copy(FHintList[CurSPos-1],1,SelStart)=Copy(Text,1,SelStart) then begin
l:=SelStart;
Dec(CurSPos);
Text:=FHintList[CurSPos];
SelStart:=Length(Text);
SelLength:=-(Length(Text)-l);
end;
Key:=VK_RETURN;
end;
VK_RETURN:begin
SelStart:=0;
SelLength:=Length(Text);
end;
end;
inherited;
end;

destructor THintEdit.Destroy;
begin
FHintList.Free;
inherited;
end;

Константин Хрипков <kostya@softincom.ru>. [000515]


Delphi 1

Числовая маска компонента Edit c помощью OnKeyPress I

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
VAR P, L : Byte;
begin
WITH Sender AS TEdit DO
BEGIN
L := Length(Text);
P := Pos('.', Text);
END;
CASE Key OF
'0'..'9' : IF (P>0) AND (L-P>1) THEN Key := #0;
'.' : IF P > 0 THEN Key := #0;
#8 : {пробел};
ELSE Key := #0;
END;
end;

Команда Key=#0 в обработчике события OnKeyPress "гасит" нажатую клавишу. Так, если нажата цифровая клавиша, то код ее "гасится", ЕСЛИ уже присутствует десятичная точка и две цифры после нее. Если введена десятичная точка, то она "гасится", ЕСЛИ десятичная точка уже присутствует. Пробел пропускается в любом случае, коды остальных клавиш всегда "гасятся". Во всяком случае теперь вы знаете "куда копать".

- Neil [000550]


Числовая маска компонента Edit c помощью OnKeyPress II

Читатель советует:

Посылаю Вам несколько расширенный вариант числовой маски компонента TЕdit c помощью OnKeyPress. В отличие от имеющегося в "Советах", приведенный код не "запирает" поле ввода при заполнении десятичной части, преобразует точку в запятую (для удобства пользователя), не позволяет поставить десятичную запятую перед числом и позволяет стирать знаки в поле ввода клавишей 'Back Space'. Код проверен в Delphi 5.

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var                                          //цифровая маска
vrPos,vrLength,vrSelStart : byte;
const
I : byte=1; //I+1 = количество знаков после запятой (в данном случае - 2 знака)
 begin
With Sender as TEdit do
begin
vrLength:=Length(Text); //определяем длину текста
vrPos:=Pos(',', Text); //проверяем наличие запятой
vrSelStart:=SelStart; //определяем положение курсора
end;

Case Key of
'0'..'9' : begin
//проверяем положение курсора и количество знаков после запятой
If (vrPos>0)and(vrLength-vrPos>I)and(vrSelStart>=vrPos)
then Key:=#0; //"погасить" клавишу
end;
',','.' : begin
//если запятая уже есть или запятую пытаются поставить перед числом или никаких цифр в поле ввода еще нет
If (vrPos>0)or(vrSelStart=0)or(vrLength=0)
then Key:=#0 //"погасить" клавишу
else Key:=#44; //всегда заменять точку на запятую
end;
#8 : ; //позволить удаление знаков клавишей 'Back Space'
else Key := #0; //"погасить" все остальные клавиши
end;

end;

С уважением, Михаил Шпанер. [000903]


Delphi 1

Edit: SetFocus в OnExit

Я пробую выполнить editbox.SetFocus и/или editbox.Clear, но но это не дает никакого эффекта (по крайней мере видимого). Что я делаю неправильно?

Вы посылаете команду на изменение фокуса внутри обработчика, который сам устанавливает фокус, этим вы получаете банальную рекурсию.

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

Следующие строки содержат необходимый код:

interface
........
const
WM_MyExitRtn = WM_USER + 1001;
........
type
TForm1 = class(TForm)
.........
private
bExitInProgress: Boolean; {предохраняемся от рекурсий сообщений}
public
Procedure WMMyExitRtn(Var msg:TMessage); message WM_MyExitRtn;
end;
.........
implementation
.........
procedure TForm1.DBEdit1Exit(Sender: TObject);
begin
If not bExitInProgress Then
PostMessage(Handle,WM_MyExitRtn,0,LongInt(Sender));
end;
.........
procedure TForm1.WMMyExitRtn(var msg:TMessage);
begin
bExitInProgress := True;           { предохраняемся от рекурсивного вызова }
{здесь содержится необходимый код }
bExitInProgress := False;          { сбрасываем флаг }
end;

[000619]


Проверка на соответствие содержимого TEdit

Как мне проверить на соответствие содержимое компонента TEdit?

Предположим, вы регулярно пользуетесь компонентами TEdit (в отличие от компонентов TDBEdit), и если так, то наилучшим местом для осуществления проверки на соответствие является обработчик события OnExit компонента TEdit. Данное событие наступает при каждом покидании фокуса компонента.

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

Решением в данной ситуации может служить попытка послать сообщение в обработчике события компонента TEdit OnExit вашей форме. Определенное пользователем и посланное сообщение может послужить отправной точкой для начала проверки содержимого поля редактирования. Поскольку посланное сообщение располагается в конце очереди сообщений, то это дает Windows возможность завершить изменение фокуса прежде, чем вы попытаетесь передать фокус другому элементу управления.

Помещенный ниже текст модуля и текстовое представление формы (DFM) призваны продемонстрировать эту технику:

{ *** НАЧАЛО КОДА МОДУЛЯ UNIT1.PAS *** }
unit Unit1;

interface

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

const
{ Определенное пользователем сообщение }
um_ValidateInput = wm_User + 100;

type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Button1: TButton;
MaskEdit1: TMaskEdit;
procedure Edit1Exit(Sender: TObject);
private
{ обработчик определенного пользователем события }
procedure ValidateInput(var M: TMessage); message um_ValidateInput;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ValidateInput(var M: TMessage);
begin
{ Следующая строка является строкой проверки. Я хочу убедиться в том, }
{ что первый символ является буквенным символом верхнего регистра. }
{ Помните о преобразовании типа lParam к TEdit. }
if not (TEdit(M.lParam).Text[1] in ['a'..'z']) then begin
ShowMessage('Содержимое не отвечает требованиям'); { Орем на пользователя }
TEdit(M.lParam).SetFocus;                          { Снова устанавливаем фокус }
end;
end;

procedure TForm1.Edit1Exit(Sender: TObject);
begin
{ Посылаем сообщение самому себе, говорящее о необходимости }
{ проверки содержимого. Передаем экземпляр TEdit (Self) как }
{ lParam сообщения. }
PostMessage(Handle, um_ValidateInput, 0, longint(Sender));
end;

end.
{ *** КОНЕЦ КОДА МОДУЛЯ UNIT1.PAS *** }

{ *** НАЧАЛО КОДА ФАЙЛА UNIT1.DFM *** }
object Form1: TForm1
Left = 200
Top = 99
Width = 318
Height = 205
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
TextHeight = 16
object Edit1: TEdit
Left = 32
Top = 32
Width = 121
Height = 24
TabOrder = 0
Text = 'Edit1'
OnExit = Edit1Exit
end
object Edit2: TEdit
Left = 160
Top = 32
Width = 121
Height = 24
TabOrder = 1
Text = 'Edit2'
OnExit = Edit1Exit
end
object Edit3: TEdit
Left = 32
Top = 64
Width = 121
Height = 24
TabOrder = 2
Text = 'Edit3'
OnExit = Edit1Exit
end
object Edit4: TEdit
Left = 160
Top = 64
Width = 121
Height = 24
TabOrder = 3
Text = 'Edit4'
OnExit = Edit1Exit
end
object Button1: TButton
Left = 112
Top = 136
Width = 89
Height = 33
Caption = 'Button1'
TabOrder = 4
end
end
{ *** КОНЕЦ КОДА ФАЙЛА UNIT1.DFM *** }

[000945]


Матрица на основе TEdit

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

Допустим, если они имеют имена с Edit1 по Edit 9, то можно попробовать сделать так:

var
eds: array[1..3,1..3] of TEdit;
ix: integer;
ed: TEdit;

for ix := 0 to 8 do begin
ed := FindComponent('Edit'+IntToStr(ix+1)) as TEdit;
if ed <> nil then eds[ix div 3 + 1,ix mod 3 + 1] := ed;
end;

Затем, допустим, вам захотелось скопировать текст из строки 1 в строку 2:

for ix := 1 to 3 do
eds[2,ix].Text := eds[1,ix].Text;

- Mike Orriss [000994]


Delphi 1

FileListBox с двумя колонками
...как сказал Майкл, вы можете сделать количество колонок > 1. Но, как это имеет место в TDirectoryListBox, колонки перекрывают одна другую. Я действительно не рекомендую это из-за потенциально возможных конфликтов во время изменения шрифта, но вы могли бы сделать по-другому:

with TDirectoryListBox(FileListBox1) do
begin
Columns := 2;
SendMessage(Handle, LB_SETCOLUMNWIDTH,
LoWord(GetTextExtent(Canvas.Handle, 'WWWWWWWW.WWW', 12)), 0);
end;

Успехов.

Kurt [000653]


Delphi 1

THeader как сплиттер
Компонент THeader может работать в качестве сплиттера. Для этого вы должны связать события OnSize с другими элементами управления, расположенными на форме. Если у вас есть исходный код компонента, вы можете это проверить. У него есть все необходимые для этого характеристики типа событий на перемещение мыши и т.п. [000399]


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

Если вы разместили изображение на форме, присвойте свойству Scaled значение False. Изображение не масштабируется. [000318]


Вопросы палитры

  1. Не используйте свойство stretch для масштабирования в меньшую сторону, для этого используйте свойство stretchdraw холста изображения.
  2. Не используйте выходящие за рамки экрана изображения без масштабирования их до размера экрана.
  3. Если вы хотите изменить изображение, используйте метод update после метода hide. К сожалению, это не указано в документации.
[000326]


Delphi 1

Изменение палитры при выводе изображения

Да, это не тривиальная задача! Палитра дочернего 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);

Если вы не делаете этот вызов, изображение отобразится с неправильной палитрой. [000386]


Delphi 1

Хитрость вывода изображения

Попробуйте установить:

Image1.ControlStyle := Image1.ControlStyle + [csOpaque];

в обработчике события формы OnCreate (или, по крайней мере прежде, чем вы покажете форму). Компоненты TImage изначально прозрачные (за исключением области, занятой изображением), поэтому сообщая Delphi, что компонент непрозрачен, вы тем самым помешаете что-либо "рисовать" на области, не занятой собственно изображением (типа клиентской области формы). [000407]


Delphi 1

Рисование прямоугольника на изображении

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

Создайте логическое поле ImageMouse, для рисования прямоугольника ImageRect используйте метод холста drawfocusrect. Следующий код работает одинаково для левой и правой кнопок мыши:

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ImageMouse := True;
ImageRect.Left := X;
ImageRect.Top  := Y;
ImageRect.Right := X;
ImageRect.Bottom  := Y;
Image1.Canvas.DrawFocusRect(ImageRect);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
Var
NewRect : tRect;
begin
if ImageMouse then
If (X > ImageRect.Left) AND (Y > ImageRect.Top) then  begin
{Восстанавливаем фон}
Image1.Canvas.DrawFocusRect(ImageRect);
{Меняем прямоугольник}
ImageRect.Right := X;
ImageRect.Bottom := Y;
{Рисуем прямоугольник фокуса}
Image1.Canvas.DrawFocusRect(ImageRect);
end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
{Восстанавливаем фон}
if ImageMouse then begin
ImageRect.Right := X;
ImageRect.Bottom := Y;
Image1.Canvas.DrawFocusRect(ImageRect);
ImageMouse := False;
Image1.Canvas.CopyRect(Image1.Canvas.ClipRect,
Image1.Canvas,ImageRect)
end;
end;

[000672]


3D-рамка для текстовых компонентов
Один из примеров создания текстового компонента с трехмерной декоративной контурной рамкой (для создания компонента потребовалось около получаса. Он демонстрирует только принцип получения рамки. Я не стал колдовать над свойствами типа ParentFont..., т.к. это заняло бы еще немало времени и места).
unit IDSLabel;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
ExtCtrls;

type
TIDSLabel = class(TBevel)
private
{ Private declarations }
FAlignment : TAlignment;
FCaption : String;
FFont : TFont;
FOffset : Byte;

FOnChange : TNotifyEvent;

procedure SetAlignment( taIn : TAlignment );
procedure SetCaption( const strIn : String);
procedure SetFont( fntNew : TFont );
procedure SetOffset( bOffNew : Byte );
protected
{ Protected declarations }
constructor Create( compOwn : TComponent ); override;
destructor Destroy; override;
procedure Paint; override;
public
{ Public declarations }
published
{ Published declarations }
property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify;
property Caption : String read FCaption write SetCaption;
property Font : TFont read FFont write SetFont;
property Offset : Byte read FOffset write SetOffset;

property OnChange : TNotifyEvent read FOnChange write FOnChange;
end;

implementation

constructor TIDSLabel.Create;
begin
inherited Create(compOwn);

FFont := TFont.Create;
with compOwn as TForm do
FFont.Assign(Font);

Offset := 4;
Height := 15;
end;

destructor TIDSLabel.Destroy;
begin
FFont.Free;

inherited Destroy;
end;

procedure TIDSLabel.Paint;
var
wXPos, wYPos : Word;
begin

{Рисуем рамку}
inherited Paint;

{Назначаем шрифт}
Canvas.Font.Assign(Font);

{Вычисляем вертикальную позицию}
wYPos := (Height - Canvas.TextHeight(Caption)) div 2;

{Вычисляем горизонтальную позицию}
wXPos := Offset;
case Alignment of
taRightJustify: wXPos := Width - Canvas.TextWidth(Caption) - Offset;
taCenter: wXPos := (Width - Canvas.TextWidth(Caption)) div 2;
end;
Canvas.Brush := Parent.Brush;
Canvas.TextOut(wXPos,wYPos,Caption);

end;

procedure TIDSLabel.SetAlignment;
begin
FAlignment := taIn;
Invalidate;
end;

procedure TIDSLabel.SetCaption;
begin
FCaption := strIn;

if Assigned(FOnChange) then
FOnChange(Self);

Invalidate;
end;

procedure TIDSLabel.SetFont;
begin
FFont.Assign(fntNew);
Invalidate;
end;

procedure TIDSLabel.SetOffset;
begin
FOffset := bOffNew;
Invalidate;
end;

end.
[000044]


Delphi 1

Комбинация TLabel и TEdit
unit Editlbl1;

interface

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

type
TLabelEdit = class(TWinControl)
private
{ Private declarations }
FEdit: TEdit;
FLabel: TLabel;
function GetLabelCaption: string;
procedure SetLabelCaption(LabelCaption: string);
function GetEditText: string;
procedure SetEditText(EditText: string);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
property LabelCaption: string read GetLabelCaption write SetLabelCaption;
property EditText: string read GetEditText write SetEditText;
property Left;
property Top;
property Width;
property Height;
property Text;
property Font;
{ Можете опубликовать другие, необходимые вам свойства. }
{ Published declarations }
end;

procedure Register;

implementation

constructor TLabelEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

FEdit := TEdit.Create(self);
FLabel := TLabel.Create(self);

with FLabel do begin
Width := FEdit.Width;
visible := true;
Parent := self;
Caption := 'LabelEdit';
end;

with FEdit do begin
Top := FLabel.Height+2;
Parent := self;
Visible := true;
end;

Top := 0;
Left := 0;
Width := FEdit.Width;
Height := FEdit.Height+FLabel.Height;
Visible := true;
end;

function TLabelEdit.GetLabelCaption: string;
begin
Result := FLabel.Caption;
end;

procedure TLabelEdit.SetLabelCaption(LabelCaption: string);
begin
FLabel.Caption := LabelCaption;
end;

function TLabelEdit.GetEditText: string;
begin
Result := FEdit.Text;
end;

procedure TLabelEdit.SetEditText(EditText: string);
begin
FEdit.Text := EditText;
end;

procedure Register;
begin
RegisterComponents('Test', [TLabelEdit]);
end;

end.
[000481]


Delphi 1

TLabel+TEdit без контейнера
При размещении на форме, создается TLabel, расположенный выше поля редактирования. При перемещении поля редактирования, TLabel "следует" за ним. При удалении поля редактирования, TLabel также удаляется. Имеется свойство LabelCaption, так что вы можете редактировать заголовок Tlabel. Вероятно вам потребуются и другие свойства TLabel, типа Font, но этот код только демонстрирует технологию, так что развивайте его по своему усмотрению.

unit LblEdit;

interface

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

type
TLabelEdit = class(TEdit)
private
FLabel : TLabel ;
procedure WMMove( var Msg : TWMMove ) ; message WM_MOVE ;
protected
procedure SetParent( Value : TWinControl ) ; override ;
function  GetLabelCaption : string ; virtual ;
procedure SetLabelCaption( const Value : string ) ; virtual ;
public
constructor Create( AOwner : TComponent ) ; override ;
destructor Destroy ; override ;
published
property LabelCaption : string read GetLabelCaption write
SetLabelCaption ;
end;

procedure Register;

implementation

constructor TLabelEdit.Create( AOwner : TComponent ) ;

begin
inherited Create( AOwner ) ;

{ создаем TLabel }
FLabel := TLabel.Create( NIL ) ;
FLabel.Caption := 'Edit label' ;
end ;

procedure TLabelEdit.SetParent( Value : TWinControl ) ;

begin
{ убеждаемся, что TLabel имеет того же родителя что и TEdit }
if ( Owner = NIL ) or not ( csDestroying in Owner.ComponentState ) then
FLabel.Parent := Value ;
inherited SetParent( Value ) ;
end ;

destructor TLabelEdit.Destroy ;

begin
if ( FLabel <> NIL ) and ( FLabel.Parent = NIL ) then
FLabel.Free ;
inherited Destroy ;
end ;

function  TLabelEdit.GetLabelCaption : string ;

begin
Result := FLabel.Caption ;
end ;

procedure TLabelEdit.SetLabelCaption( const Value : string ) ;

begin
FLabel.Caption := Value ;
end ;

procedure TLabelEdit.WMMove( var Msg : TWMMove ) ;

begin
inherited ;

{ заставляем TLabel 'прилипнуть' к верху TEdit }
if FLabel <> NIL then with FLabel do
SetBounds( Msg.XPos, Msg.YPos - Height, Width, Height ) ;
end ;

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

initialization
{ Мы используем TLabel, поэтому для обеспечения "поточности" необходима регистрация }
RegisterClass( TLabel ) ;
end.

- Mike Scott [000779]


Delphi 2

TListView, TTreeView

У меня есть TTreeView и TListView, размещенные точно так же, как это сделано в Windows Explorer (фактически я хочу им придать и то же функциональное назначение). Как мне сделать следующее:

При двойном щелчке на элементе ListView узнать его индекс? Затем, как мне 'открыть' ветку и папку в компоненте TreeView, являющегося 'родителем' данного элемента? (В точном соответствии с функциональностью Проводника, к этому моменту родительский узел TreeView должен уже быть выбран - поэтому, я понимаю, необходимо правильно определить дочерний узел - но я чего-то запутался в синтаксисе).

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

Как вы можете здесь видеть, ключем здесь является функция NodeAtIndex. Данный пример подразумевает наличие дочерних узлов и индексов, начиная с нуля. Так, если мы подразумеваем что был выбран родительский узел списка элементов, (что является безопасным предположением), то мы можем использовать данный узел как отправной пункт. Методы GetFirstChild и GetNextSibling "отправляют" вас к желаемому узлу.

function TFrmTipExplorer.NodeAtIndex( Index : Integer ) : TTreeNode;
var
I : Integer;
begin
Result := TreeView1.Selected.GetFirstChild;
for I := 0 to Index - 1 do
Result := Result.GetNextSibling;
end;

procedure TFrmTipExplorer.ListView1DblClick(Sender: TObject);
begin
TreeView1.Selected.Expand( False );
{ Выбираем узел дерева, соответствующий "щелканному" элементу списка }
NodeAtIndex( ListView1.Selected.Index ).Selected := True;
end;

- Ray Konopka [000946]


Изменение шрифта в Listbox

Вероятно иногда бывает полезным установить шрифт с фиксированной шириной символов в вашем Listbox.

Есть одно решение данной проблемы - использовать системные фиксированные шрифты - System-Fixed-Font (по крайней мере в Windows 3.11 -- как насчет Windows 95?). Единственную вещь, которую вы должны сделать - установить шрифт программным путем в момент создания формы.

Вот пример (здесь LB - ListBox), где шрифт устанавливается после добавления нескольких строк в ListBox:

LB.Items.Clear;

for i := 0 to (SL.Count)-1 do
begin
LB.Items.Add(Copy(SL.Strings[i], 1, j-1));
end;

{ !!!!! ТЕПЕРЬ УСТАНАВЛИВАЕМ ЖЕЛАЕМЫЙ ШРИФТ !!!!! }
{ System_Fixed_Font или ANSI_Fixed_Font }
 SendMessage(LB.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);
[000148]


Колонки в TListBox

Установите свойство TabWidth в редакторе свойств ListBox. Можете даже не пытаться найти это в файле помощи. К примеру, если ширина вашего listbox равняется 300 пикселей, установите значение TabWidth равным 100 или около этого.

При добавлении новых строк в ListBox разнесение элементов по колонкам возможно, к примеру, с помощью ключа ^I:

ListBox1.Items.Add('Колонка1'^I'Колонка2'^I'Колонка3');

Я проверил это только что еще раз - все действительно работает как надо. Но я до сих пор не разобрался как менять ширину колонок. И вы после этого будете слепо доверять документации? (Сарказм) [000149]


Изменение позиций элементов ListBox с помощью drag&drop I

Единственно интересный код:

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
with (Sender as TListBox) do
Items.Move(ItemIndex,ItemAtPos(Point(x,y),True));
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := (Sender=Source);
end;

Не забудьте в ListBox присвоить свойству DragMode значение dmAutomatic.

[000150]


Delphi 1

Изменение позиций элементов ListBox с помощью drag&drop II

Я хотел бы изменить порядок следования элементов в неотсортированном списке ListBox методом drag&drop, т.е. просто перетаскивая их мышью на нужное место. Будет еще лучше, если при удержании кнопки мыши перетаскиваемый элемент визуально перемещал бы вверх или вниз сам список (для определения своего нового месторасположения) до тех пор, пока клавиша мыши не будет отпущена (как я понял, автоматическое скроллирование - В.О.).

Попробуйте для начала это:

unit Draglb;

interface

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

type
TDragListBox = class(TListBox)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
procedure DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure DragDrop(Sender, Source: TObject; X, Y: Integer);
constructor Create(AOwner: TComponent); override;
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Custom', [TDragListBox]);
end;

constructor TDragListBox.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
DragMode := dmAutomatic;
OnDragDrop := DragDrop;
OnDragOver := DragOver;
end;

procedure TDragListBox.DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source = Self;
end;

procedure TDragListBox.DragDrop(Sender, Source: TObject; X, Y: Integer);
var
Value: Integer;
begin
if Sender = Self then
begin
Value:=Self.ItemAtPos(Point(x,y), True);

if Value = -1 then
begin
Self.Items.Add(Self.Items[Self.ItemIndex]);
Self.Items.Delete( Self.ItemIndex);
end else
begin
Self.Items.Insert(Value {+ 1}, Self.Items[Self.ItemIndex]);
Self.Items.Delete( Self.ItemIndex);
end;
end;
end;

end.

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

Nick Hodges
Monterey, CA [000575]


Delphi 1

Изменение позиций элементов ListBox с помощью drag&drop III

Если вы хотите принимать перетаскиваемый объект, только если он представляет собой собственный элемент, то в обработчике OnDragOver вставьте строчку "Accept := Source=Sender;". Ниже приведен код, позволяющий сортировать элементы с помощью перетаскивания их мышкой внутри списка компонента. Вам также понадобится таймер для обеспечения функции автопрокручивания. Это означает, что при перетаскивании элемента в верхнюю часть списка, он при необходимости прокручивается вниз, дабы стали видны невидимые в верхней части списка элементы. Если вам не нужно такое поведение компонента, исключите из кода все строчки, имеющие отношение к таймеру, включая вторую строчку в обработчике события OnDragOver.

...
private
{ Private declarations }
GoingUp : Boolean;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject;
X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := (Sender = Source) AND
(TListBox(Sender).ItemAtPos(Point(X,Y),False) >= 0);
{устанавливаем таймер для автопрокрутки}
IF Accept THEN
WITH Sender AS TListBox DO
IF Y>Height-ItemHeight THEN
BEGIN
GoingUp := False;
Timer1.Enabled := True;
END
ELSE IF Y>ItemHeight THEN
BEGIN
GoingUp := True;
Timer1.Enabled := True;
END
ELSE Timer1.Enabled := False;
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject;
X, Y: Integer);
VAR NuPos: Integer;
begin
WITH Sender AS TListBox DO
BEGIN
NuPos := ItemAtPos(Point(X,Y),False);
IF NuPos >= Items.Count THEN Dec(NuPos);
Label1.Caption := Format('Перемещено из %d в %d',
[ItemIndex, NuPos]);
Items.Move(ItemIndex, NuPos);
{выделяем перемещенный элемент}
ItemIndex := NuPos;
END;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
WITH ListBox1 DO
IF GoingUp THEN
IF TopIndex>0 THEN TopIndex := TopIndex-1
ELSE Timer1.Enabled := False
ELSE
IF TopIndex<Items.Count-1 THEN TopIndex := TopIndex+1
ELSE Timer1.Enabled := False;
end;

procedure TForm1.ListBox1EndDrag(Sender, Target: TObject;
X, Y: Integer);
begin
Timer1.Enabled := False;
end;

[000649]


Delphi 1

Изменение позиций элементов ListBox с помощью drag&drop IV

Вот еще одна вариация сабжа.

procedure TPickParty.PickListBMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin
if Button = mbLeft then
with Sender as TListBox do
begin
DraggedPM:= ItemAtPos(Point(X,Y), True);
if DraggedPM >l;= 0 then BeginDrag(False);
end;
end;

procedure TPickParty.PickListBDragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);

begin
if Source = PickListB then Accept:= True;
end;

procedure TPickParty.PickListBDragDrop(Sender, Source: TObject; X,Y: Integer);
var NewIndex: integer;
begin
NewIndex:= PickListB.ItemAtPos(Point(X,Y), False);
if NewIndex > PickListB.Items.Count-1 then
NewIndex:= PickListB.Items.Count-1;
PickListB.Items.Move(DraggedPM, NewIndex);
PickListB.ItemIndex:= NewIndex;
end;

- Peter Donnelly [000756]


Компонент Check List

Вопрос:

Я ищу компонент ListBox, который может отображать квадратик с галочкой (check box) для выбранных элементов списка - компонент CheckList, если вам будет угодно (просто последний компонент содержит меньший набор характеристик, чем мне необходимо).

  1. Загрузите 'Adding Graphics in your listboxes and comboboxes' (дополнительная графика для компонентов ListBox и Combobox) из Borland Technical Information - документ TI2793.
  2. Добавьте в ваш ListBox изображение неотмеченного квадратика.
  3. Используя событие двойного щелчока заменяйте изображение на отмеченный квадратик.
Рисование графики в коде для компонентов ListBox и ComboBox

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

В: Как мне вставить свою графику в Listbox или ComboBox???

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

  1. Создайте форму.
  2. Расположите на вашей форме компоненты ComboBox и Listbox.
  3. Измените свойство Style компонента ComboBox на csOwnerDrawVariable и свойство Style компонента ListBox на lbOwnerDrawVariable. Обработчик события OnDrawItem компонентов TListBox или TComboBox позволяет осуществить вывод как объекта (графики), так и строки элемента. В данном примере осуществляется вывод как графического объекта, так и строки.
  4. Создайте 5 переменных типа TBitmap в VAR секции вашей формы.
  5. Создайте процедуру для события формы OnCreate.
  6. Создайте процедуру для события ComboBox OnDraw.
  7. Создайте процедуру для события ComboBox OnMeasureItem.
  8. Освободите ресурсы в обработчике события формы OnClose.
{НАЧАЛО OWNERDRW.PAS}
unit Ownerdrw;

interface

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

type
TForm1 = class(TForm)
ComboBox1: TComboBox;
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ComboBox1MeasureItem(Control: TWinControl; Index:
Integer;
var Height: Integer);
procedure ListBox1DrawItem(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;
TheBitmap1, TheBitmap2, TheBitmap3, TheBitmap4,
TheBitmap5 : TBitmap;
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
TheBitmap1 := TBitmap.Create;
TheBitmap1.LoadFromFile('C:\delphi\images\buttons\globe.bmp');
TheBitmap2 := TBitmap.Create;
TheBitmap2.LoadFromFile('C:\delphi\images\buttons\video.bmp');
TheBitmap3 := TBitmap.Create;
TheBitmap3.LoadFromFile('C:\delphi\images\buttons\gears.bmp');
TheBitmap4 := TBitmap.Create;
TheBitmap4.LoadFromFile('C:\delphi\images\buttons\key.bmp');
TheBitmap5 := TBitmap.Create;
TheBitmap5.LoadFromFile('C:\delphi\images\buttons\tools.bmp');
ComboBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1);
ComboBox1.Items.AddObject('Изображение2: Видео', TheBitmap2);
ComboBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3);
ComboBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4);
ComboBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5);
ListBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1);
ListBox1.Items.AddObject('Изображение2: Видео', TheBitmap2);
ListBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3);
ListBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4);
ListBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
TheBitmap1.Free;
TheBitmap2.Free;
TheBitmap3.Free;
TheBitmap4.Free;
TheBitmap5.Free;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:
Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TComboBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap(ComboBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ отображаем текст }
TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index])
end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index:
Integer; var Height: Integer);
begin
height:= 20;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index:
Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TListBox).Canvas do
begin

FillRect(Rect);
Bitmap := TBitmap(ListBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ отображаем текст }
TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index])
end;
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index:
Integer;
var Height: Integer);
begin
height:= 20;
end;

end.
{КОНЕЦ OWNERDRW.PAS}

{НАЧАЛО OWNERDRW.DFM}
object Form1: TForm1
Left = 211
Top = 155
Width = 435
Height = 300
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
OnClose = FormClose
OnCreate = FormCreate
TextHeight = 16
object ComboBox1: TComboBox
Left = 26
Top = 30
Width = 165
Height = 22
Style = csOwnerDrawVariable
ItemHeight = 16
TabOrder = 0
OnDrawItem = ComboBox1DrawItem
OnMeasureItem = ComboBox1MeasureItem
end
object ListBox1: TListBox
Left = 216
Top = 28
Width = 151
Height = 167
ItemHeight = 16

Style = lbOwnerDrawVariable
TabOrder = 1
OnDrawItem = ListBox1DrawItem
OnMeasureItem = ListBox1MeasureItem
end
end
{КОНЕЦ OWNERDRW.DFM}

[000151]


TabStop в Listbox I

unit TabsLBox;
{включение табуляторов в listbox}
interface

uses WinTypes, Classes, Controls, StdCtrls;

type
TMyListBox = class(TListBox)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;

procedure register;

implementation

procedure register;
begin
RegisterComponents('Samples',[TMyListBox]);
end;

procedure TMyListBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style:= Params.Style or LBS_USETABSTOPS;
end;

end.

[000152]


Как сделать так, чтобы каждая строка в ListBox имела свой цвет?

У меня есть два примера процедур OnDrawItem:

procedure TTest.ListBox1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
With ( Control As TListBox ).Canvas Do
Begin
Case Index Of
0:
Begin
Font.Color  := clBlue;
Brush.Color := clYellow;
End;
1:
Begin
Font.Color  := clRed;
Brush.Color := clLime;
End;
2:
Begin
Font.Color  := clGreen;
Brush.Color := clFuchsia;
End;
End;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, ( Control As TListBox ).Items[Index]);
End;
end;

Вышеприведенный код устанавливает различный цвет у фона и текста в зависимости от номера строки, но он не работает с выделенными/выбранными строками (кстати, не забудьте установить значение свойства ListBox1.Style равным lbOwnerDrawFixed.)

procedure TListTest.ListBox1DrawItem( Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState );

Const
HighLight = 'LINE';

Var
TempLine, TempText, TempHigh: String;
TempLeft, TempTop, TempStart: Integer;
OldColor: TColor;

begin
with ( Control as TListBox ).Canvas do
begin
FillRect( Rect );
TempLeft := Rect.Left + 3;
TempTop := Rect.Top + 1;
TempLine := ( Control as TListBox ).Items[ Index ];

While TempLine > '' Do
Begin
TempStart := Pos( HighLight, AnsiUpperCase( TempLine ) );

If TempStart > 0 Then
Begin
TempText := Copy( TempLine, 1, TempStart - 1 );
TempHigh := Copy( TempLine, TempStart, Length( HighLight ) );
Delete( TempLine, 1, TempStart + Length( HighLight ) - 1 );
End
Else
Begin
TempText := TempLine;
TempHigh := '';
TempLine := '';
End;

If TempText > '' Then
Begin
TextOut( TempLeft, TempTop, TempText );
Inc( TempLeft, TextWidth( TempText ) );
End;

If TempHigh > '' Then
Begin
OldColor := Font.Color;
If odSelected In State Then
Font.Color := clYellow
Else
Font.Color := clBlue;
TextOut( TempLeft, TempTop, TempHigh );
Inc( TempLeft, TextWidth( TempHigh ) );
Font.Color := OldColor;
End;
End;
end;
end;

Это можно протестировать со следующими тремя строками:

'Строка номер один'
'Вторая строка'
'Это строчка номер три'

Есть несколько вещей, достойных упоминания:

Я использую параметр Control для приведения типов ( Control as TListBox ).Items[ Index ], что убедиться в том, что я использую данные ListBox, такой способ позволяет сделать общим данный обработчик события для нескольких компонентов TListBox, например, если у вас имеется пара ListBox на различных страницах TNoteBook.

OldColor и проверка параметра State позволяет быть уверенным, что выбранная строка содержит видимый цвет шрифта (множество видеодрайверов используют белый текст на синем фоне для выбранной строки).

Также я создаю небольшое свободное пространство вокруг текста - увеличиваю TListBox.ItemHeight и, соответственно, область вывода текста - TempLeft := Rect.Left + 3 и TempTop := Rect.Top + 1.

[000153]


Инкрементальный поиск в ListBox I

Предположим, что 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) элемента. [000422]


Delphi 1

Расширение компонента ListBox

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

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

Вот код.

unit Unit1;

interface

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

type
TTraQsListBox = class(TListBox)
private
FDoubleClickBtn : TButton;
protected
procedure DblClick; override;
public
published
property DoubleClickBtn : TButton read FDoubleClickBtn write FDoubleClickBtn;
end;

procedure Register;

implementation

{TTraQsListBox}
procedure TTraQsListBox.DblClick;
begin
if Assigned(FDoubleClickBtn) then
FDoubleClickBtn.Click
else
inherited DblClick;
end;

procedure Register;
begin
RegisterComponents('My Components', [TTraQsListBox]);
end;

end.

[000541]


Delphi 1

Уменьшение мерцания 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 [000548]


Delphi 1

Пример Ownerdraw для Listbox

Вот пример обработчика OnDrawItem, выводящий английские гласные в красном цвете:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
VAR
S : String;
N : Word;
WasColor : TColor;
begin
WITH Control AS TListBox, Canvas DO
BEGIN
S := Items[Index];
FillRect(Rect);
MoveTo(Rect.Left+2, Rect.Top);
SetTextAlign(Canvas.Handle, TA_LEFT OR TA_UPDATECP);
WasColor := Font.Color;
FOR N := 1 TO Length(S) DO
BEGIN
CASE UpCase(S[N]) OF
'A','E','I','O','U': Font.Color := clRed;
ELSE Font.Color := WasColor;
END;
WinProcs.TextOut(Canvas.Handle, 0, 0, @S[N], 1);
END;
END;
end;

Обратите внимание на то, что для того, чтобы использовать стиль TA_UPDATECP (при котором каждый следующий вызов TextOut выводил текст в позиции, расположенной после предшествуюшей), необходимо использовать функцию API function TextOut (WinProcs.TextOut) вместо метода объекта Delphi Canvas TextOut.

- Neil [000607]


Delphi 1

Обнаружение прокрутки TListBox

Как мне определить, что потребитель двигает полосы прокрутки в Tlistbox?

Просто ловите сообщение WMVScroll...

Хмм, было бы неплохо отлавиливать это сообщение и генерировать для этого случая событие OnVScroll. Например так:

unit Listbob;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TListBob = class(tlistbox)
private
{ Private declarations }
FOnHScroll: TNotifyEvent;
FOnVScroll: TNotifyEvent;
protected
{ Protected declarations }
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property OnHScroll: TNotifyEvent read FOnHScroll write FOnHScroll;
property OnVScroll: TNotifyEvent read FOnVScroll write FOnVScroll;
end;

procedure Register;

implementation

constructor TListBob.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOnHScroll := nil;
FOnVScroll := nil;
end;

procedure TListBob.WMHScroll(var Message: TWMHScroll);
{ помните что данное сообщение вызывается дважды!! }
begin
if Assigned(FOnHScroll) then FOnHScroll(Self);
DefaultHandler(Message);
end;

procedure TListBob.WMVScroll(var Message: TWMHScroll);
{ помните что данное сообщение вызывается дважды!! }
begin
if Assigned(FOnVScroll) then FOnVScroll(Self);
DefaultHandler(Message);
end;

procedure Register;
begin
RegisterComponents('Dr.Bob', [TListBob]);
end;

end.

Dr. Bob (drbob@pi.net) [000685]


Delphi 1

Щелчок в пустой области TListBox

Я хочу, чтобы мой TListBox имитировал поведение Delphi Watch List, отвечающий на двойной щелчок мышью диалоговым окном. Я добился такого эффекта, добавив обработку события OnDoubleClick к моей форме. Но в случае двойного щелчка в области, расположенной ниже последнего элемента списка, я хочу открывать диалоговое окно "добавить новый элемент". Но вот это никак не вытанцовывается. Метод OnDoubleClick не вызывается, если я щелкаю в TListBox, но щелчок приходится не на элемент списка, а на пустое место.

Попробуйте это....

Добавьте следующий обработчик OnMouseDown в ваш ListBox...

procedure TForm1.ListBox1MouseDown(...куча параметров...)
begin
if ( Button = mbLeft ) then
begin
with  Sender as TListBox  do
begin
if ( (ItemAtPos(Point(X,Y), True) = -1) and
(ssDouble in Shift) ) then
begin
{ ДВОЙНОЙ ЩЕЛЧОК В ПУСТОЙ ОБЛАСТИ }
end;
end;
end;
end;

Alan Ciemian
Ciemian Computer Services [000686]


Delphi 1

Использование выбранных элементов TListBox

...это будет действительно классно, если я смогу просто переместить выбранные элементы в StringList. Или, например, вообще удалить невыбранные элементы из ListBox.

Следующий код перемещает все выбранные элементы ListBox1 в ListBox2:

procedure TForm1.Button1Click(Sender: TObject);
var ix:integer;
begin
with ListBox1 do begin
if SelCount < 1 then exit;
for ix := 0 to Items.Count-1 do
if Selected[ix] then ListBox2.Items.Add(Items[ix]);
for ix := Items.Count-1 downto 0 do
if Selected[ix] then Items.Delete(ix);
end;
end;

=== Mike Orriss === [000692]


Расширение TListBox

Я пытаюсь осуществить предварительную загрузку элементов наследника TListBox со множеством строк. Для этого я перекрываю конструктор, добавляя в него строки типа items.add('foo'); но когда я выполняю это, то получаю исключение "window has no parent window" (окно не имеет родительского окна). Почему у меня не получается сделать это?

Listbox сохраняет элементы, передавая их Windows. При этом требуется дескриптор окна, а дескриптору окна требуется родитель. Родитель не устанавливается даже после возврата из конструктора.

Решение проблемы:

   SaveVis := Visible;
   Visible := False;
   Parent  := Owner;
   <заполнение ListBox>
   Parent  := Nil;
   Visible := SaveVis;
- Scott Samet [000950]


Перехват клавиши SHIFT во время выбора пункта меню

Попробуйте это:

procedure TForm1.Menu11Click(Sender: TObject);
begin
{Проверяем нажатость клавиши Shift}
if HiWord(GetKeyState(VK_SHIFT)) <> 0 then
Label1.Caption := 'Shift'
else
{Проверяем нажатость клавиши Ctrl}
if HiWord(GetKeyState(VK_CONTROL)) <> 0 then
Label1.Caption := 'Control'
else
{Проверяем нажатость клавиши Alt}
if HiWord(GetKeyState(VK_MENU)) <> 0 then
Label1.Caption := 'Alt'
else
Label1.Caption := 'Никакая из управляющих клавиш не нажата';
end;
[000173]


Добавление иконки в меню

Как добавить иконку в меню? Можно так:

var
Bmp1 : TPicture;

...

Bmp1 := TPicture.Create;
Bmp1.LoadFromFile('c:\where\b1.BMP');
SetMenuItemBitmaps(     MenuItemTest.Handle,
0,
MF_BYPOSITION,
Bmp1.Bitmap.Handle,
Bmp1.Bitmap.Handle);
...

Создаем изображение.

Загружаем какое-либо изображение формата .BMP.

Используем вызов API SetMenuItemBitmaps для подключения изображения к меню со следующими параметрами:

  1. MenuItemTest - имя для горизонтального (верхнего) пункта меню
  2. 0,1 ... - пункты меню, которым необходимо добавить иконку (первый пункт имеет индекс 0).
Первый дескриптор изображения ссылается на первую иконку, выводимую когда пункт меню неотмечен (невыбран). Второй - если пункт меню отмечен (checked). Возможно использование одного изображения (как в нашем случае).

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

Результат: Это работает, но в качестве иконки выводится только правая верхняя часть изображения (которое поместилось). Известите меня, если вам удалось изменить высоту (или ширину) пункта меню соразмерно выводимому изображению. [000175]


Динамическое добавление пунктов меню I

Решение 1

Честно говоря, я так и не понял к чему вы хотите добавлять новые пункты меню - к верхнему уровню или в качестве подменю. На всякий случай я публикую оба метода. Выбирайте любой.

Новый элемент верхнего уровня:

procedure tform1.addmainitem(s:string);
var
newitem : Tmenuitem;
begin
newitem:=tmenuitem.create(Mainmenu1);
newitem.caption:=s;
{если вы хотите определить событие onclick
newitem.onclick:=Dynamenuclick; }
{добавляем это к верхнему уровню меню}
mainmenu1.items.insert(mainmenu1.items.count,newitem);
removemenu1.enabled:=true;
addmenuitem1.enabled:=true;
end;

Создание подменю:

procedure tform1.addsubitem(s:string; to : integer);
var
newitem, toitem : Tmenuitem;
begin
{to = верхний уровень меню для нового пункта}
toitem:=mainmenu1.items[to];
newitem:=tmenuitem.create(toitem);
newitem.caption:=s;
{если вы хотите определить событие onclick
newitem.onclick:=Dynamenuclick; }
toitem.onclick:=nil;
toitem.insert(toitem.count,newitem);
removemenuitem1.enabled:=true;
end;

Решение 2

Вы можете использовать готовые функции, определенные в модуле Menus. Определения в Delphi 2:

function NewMenu(Owner: TComponent; const AName: string; Items: array
of TMenuItem): TMainMenu;
function NewPopupMenu(Owner: TComponent; const AName: string;
Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of
TMenuitem): TPopupMenu;
function NewSubMenu(const ACaption: string; hCtx: Word; const AName:
string; Items: array of TMenuItem): TMenuItem;
function NewItem(const ACaption: string; AShortCut: TShortCut;
AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
const AName: string): TMenuItem;
function NewLine: TMenuItem;

Это превращает вышепоставленную задачу в сущий пустяк. [000176]


Delphi 1

Динамическое добавление пунктов меню II

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

unit Istopmnu;

interface

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

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
SubMenu1: TMenuItem;
procedure AClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AClick(Sender: TObject);
VAR
TM : TMenuItem;
Lev : Word;
begin
MessageBeep(0);
TM := Sender AS TMenuItem;
IF TM.Count > 0 THEN
Caption := 'подменю'
ELSE Caption := 'элемет меню';
Caption := Caption + ' с именем "' + TM.Name + '"';
Lev := 0;
WHILE (TM.Parent <> NIL) AND (TM.Parent IS TMenuItem) DO
BEGIN
TM := TM.Parent;
Inc(Lev);
END;
CASE Lev OF
1 : Caption := 'Верхний уровень ' + Caption;
2 : Caption := '2-й уровень ' + Caption;
3 : Caption := '3-й уровень ' + Caption;
ELSE Caption := Format('%d-й уровень %s', [Lev, Caption]);
END;
end;

procedure TForm1.FormCreate(Sender: TObject);
VAR
TM : TMenuItem;
N  : Integer;
begin
TM := SubMenu1;
TM.Add(NewItem('&Элемент',0,False,True,AClick,0,'MenuItem2'));
FOR N := 2 TO 5 DO
BEGIN
TM.Add(TMenuItem.Create(nil));
TM := TM.Items[TM.Count-1];
TM.Caption := '&Меню';
TM.Name := 'SubMenu'+IntToStr(N);
TM.OnClick := AClick;
TM.Add(NewItem('&Элемент',0,False,True,AClick,0,
'MenuItem'+IntToStr(N+1)));
END;
MainMenu1.Items.Add(NewSubMenu('Меню&2', 0, 'SM1',
[NewItem('&Элемент',0,False,True,AClick,0,'MI2'),
NewSubMenu('&Меню', 0, 'SM2',
[NewItem('&Элемент',0,False,True,AClick,0,'MI3'),
NewSubMenu('&Меню', 0, 'SM3',
[NewItem('&Элемент',0,False,True,AClick,0,'MI4'),
NewSubMenu('&Меню', 0, 'SM4',
[NewItem('&Элемент',0,False,True,AClick,0,'MI5'),
NewSubMenu('&Меню', 0, 'SM5',
[NewItem('&Элемент',0,False,True,AClick,0,'MI6')
])
])
])
])
]));
TM := MainMenu1.Items[1];
WHILE TRUE DO
BEGIN
TM.OnClick := AClick;
IF TM.Count < 2 THEN Break;
TM := TM.Items[1];
END;
end;

end.

- Neil J. Rubenking [000769]


Очень длинные меню

Данный код изменяет количество пунктов меню в зависимости от текущего разрешения. Данная схема работает безукоризненно. В нижеприведенном коде mnuView - выводимое меню, HandleMenuClick - назначенный обработчик для события OnClick.

procedure TfrmMain.LoadViewMenu;
var
itemNum: integer;
mnu: TMenuItem;
menuItemHeight: integer;
itemsPerColumn: integer;
begin
{удаляем все видимые пункты меню}
while mnuView.Count > 0 do begin
{метод Free удаляет пункт меню}
mnuView.Items[0].Free;
end;

{находим высоту каждого пункта меню.
Значение 2 получено в результате экспериментов}
menuItemHeight := GetSystemMetrics(SM_CYMENU) + 2;

{вычисляем количество пунктов в колонке меню}
itemsPerColumn := screen.height div menuItemHeight;

{создаем пункты меню}
for itemNum := 0 to 99 do begin
mnu := TMenuItem.Create(self);
mnu.caption := 'Пункт ' + inttostr(itemNum);

{при необходимости начинаем с новой колонки}
if (itemNum mod itemsPerColumn = 0) and (itemNum>0) then begin
mnu.break := mbBarBreak;
end;

{назначаем обработчик события OnClick}
mnu.OnClick := HandleMenuClick;

mnuView.Add(mnu);
end;
end;

[000177]


Пункт меню "Помощь" в правой части окна

Пример помещения корневого пункта меню в правую часть окна:

unit ODMenuU;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms,
Dialogs, Menus, StdCtrls;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
FileItem1: TMenuItem;
ExitItem1: TMenuItem;
HelpItem1: TMenuItem;
About1: TMenuItem;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
{ Перемещаем корневой пункт меню "Помощь" в правую часть окна }
{ Windows 95/NT 4 поддерживают это таким образом ... }
{$IFNDEF ALTERNATIVEWAY}
ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,
HelpItem1.Handle, '&Помощь');
{$ELSE}
{ ... а Win 3.xx таким образом: }
HelpItem1.Caption := #8 + HelpItem1.Caption;
{$ENDIF}
end;

end.

Это все! Просто? :)

Даже несмотря на то, что Microsoft в Windows Styles Guides говорит о недопустимости правого расположения пунктов меню, вы наперекор этому можете это сделать. Вам необходимо проверить файл электронной справки с описанием второго и третьего параметров функций GetMenuItemInfo и SetMenuItemInfo.

procedure TForm1.FormCreate(Sender: TObject);
var
MMI: TMenuItemInfo;
MyMenu: hMenu;
Buffer: array[0..79] of Char;
begin
MyMenu := GetMenu(Handle);
// Handle является дескриптором формы, содержащей меню
MMI.cbSize := SizeOf(MMI);
MMI.fMask := MIIM_TYPE;
MMI.dwTypeData := Buffer;
MMI.cch := SizeOf(Buffer);
GetMenuItemInfo(MyMenu, 1, True, MMI);
// (..., 1, True, ...) означает что "Помощь" является вторым пунктом меню.
MMI.fType := MMI.fType or MFT_RIGHTJUSTIFY;
SetMenuItemInfo(MyMenu, 1, True, MMI);
end;

И сразу после опубликования совета пришло мне письмо:

Все хорошо, но мне кажется правильнее так: (Меню постоянно меняется, и помнить о индексе?? Зачем, наименование не изменно, заголовок как правило тоже...)

procedure TForm1.FormCreate(Sender: TObject);
begin

{ Перемещаем корневой пункт меню "Помощь" в правую часть окна }
{ Windows 95/NT 4 поддерживают это таким образом ... }
{$IFNDEF ALTERNATIVEWAY}
ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,

>>> ModifyMenu(MainMenu1.Handle, HelpItem1.MenuIndex, mf_ByPosition or
mf_Popup or mf_Help, (мнение автора)

HelpItem1.Handle, '&Помощь');
{$ELSE}
{ ... а Win 3.xx таким образом: }
HelpItem1.Caption := #8 + HelpItem1.Caption;
{$ENDIF}
end;

С уважением, Вадим В. Приставко, pristavko@writeme.com Кольская АЭС [000178]


Delphi 1

Слияние MDI-меню

Delphi не совсем корректно производит объединение меню в MDI приложениях. Если окно MDIChild максимально развернуто, и добавляется другое окно MDIChild, управляющее MDIChild меню (родительское основное меню) или исчезает совсем, или делает это на момент нажатия на него.

По всей видимости, для слияния меню Delphi использует InsertMenu() с MF_POSITION. Тем не менее, если дочернее MDI-окно максимально развернуто, Popup меню добавляется к меню MDI-приложения, вставляясь на одну позицию дальше, чем необходимо. Это стандартное поведение системы, поскольку системное меню активного дочернего окна включается в первую позицию панели меню MDI-окна.

Согласно WinSDK, если активное дочернее окно максимально развертывается, вставляется новое popup-меню, при этом к значению позиции добавляется 1 (единица). [000346]


Delphi 1

Назначение обработчика MenuItem OnClick

SomeMenuItem.OnClick := SomeMethod;

Имейте в виду, что SomeMethod должен быть методом объекта, а не автономной процедурой и иметь ту же форму, что и TNotifyEvent; т.е. метод должен принимать единственный параметр (Sender) типа TObject. [000540]


Озорные меню

В своем меню я хочу иметь графику. Но как мне сделать это?

Воспользуйтесь командой 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. Попробуйте это!

- Neil Rubenking [000999]


Delphi 1

Запись с помощью MediaPlayer

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

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;
try
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.CString;
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;
end;

Nick Hodges [000509]


?? Прокрутка Memo ??

И вот что я вам отвечу:

Var
ScrollMessage:TWMVScroll;

ScrollMessage.Msg:=WM_VScroll;
for i := Memo1.Lines.Count DownTo 0 do
begin
ScrollMessage.ScrollCode:=sb_LineUp;
ScrollMessage.Pos:=0;
Memo1.Dispatch(ScrollMessage);
end;
[000171]


Событие "Key press" и курсорные клавиши (стрелки) в Tmemo

Мне необходимо обновлять текущую строку в во время перемещения по ним с помощью курсорных клавиш.

Вам повезло. Совсем недавно мне пришлось помучиться с этой задачкой. Я переместил функции в отдельный модуль. Для тестирования кода создайте пустую форму с одним компонентом Tmemo.

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

Данный пример отображает в заголовке текущие координаты курсора (столбец, строка).

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

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

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Memo1: TMemo;
procedure Memo1Change(Sender: TObject);
procedure Memo1Click(Sender: TObject);
procedure Memo1Enter(Sender: TObject);
procedure Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Function GetLineIndex : Word;
Function GetStrInsertIndex : Word;
procedure GetCursorCoord;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

Function TForm1.GetLineIndex : Word;
begin
Result:=SendMessage(Memo1.handle,EM_LINEFROMCHAR,memo1.selstart,0);
end;

Function TForm1.GetStrInsertIndex : word;
begin
GetStrInsertIndex :=
memo1.Selstart-SendMessage(Memo1.handle,EM_LINEINDEX,GetLineIndex,0)
end;

procedure TForm1.GetCursorCoord;
var LineIndex: word;
LineChar : byte;
SelSt : word;
begin
SelSt:=Memo1.selstart;
LineIndex:=GetLineIndex;
Linechar:=GetStrInsertIndex;

if Memo1.seltext>''
then Caption:='Выбранный текст'
else Caption:='Колонка '+ inttostr(LineChar+1)+' , ' +
'Строка '+ inttostr(Lineindex+1);
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1Click(Sender: TObject);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1Enter(Sender: TObject);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
GetCursorCoord;
end;

procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
GetCursorCoord;
end;

end.
[000172]


Поиск и замена текста в Tmemo

procedure TForm1.FindDialog1Find(Sender: TObject);
VAR
Buff, P, FT : PChar;
BuffLen     : Word;
begin
WITH Sender AS TFindDialog DO
BEGIN
GetMem(FT, Length(FindText) + 1);
StrPCopy(FT, FindText);
BuffLen := Memo1.GetTextLen + 1;
GetMem(Buff, BuffLen);
Memo1.GetTextBuf(Buff, BuffLen);
P := Buff + Memo1.SelStart + Memo1.SelLength;
P := StrPos(P, FT);
IF P = NIL THEN MessageBeep(0)
ELSE
BEGIN
Memo1.SelStart := P - Buff;
Memo1.SelLength := Length(FindText);
END;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff, BuffLen);
END;
end;

procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
begin
WITH Sender AS TReplaceDialog DO
WHILE True DO
BEGIN
IF Memo1.SelText <> FindText THEN
FindDialog1Find(Sender);
IF Memo1.SelLength = 0 THEN Break;
Memo1.SelText := ReplaceText;
IF NOT (frReplaceAll IN Options) THEN Break;
END;
end;
[000363]


Delphi 1

Текущая позиция Tmemo I

CurrentLine :=SendMessage(Memo1.Handle,
EM_LINEFROMCHAR,Memo1.SelStart, 0);

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

ColNum := Memo1.SelStart-SendMessage(Memo1.Handle,
EM_LINEINDEX,CurrentLine, 0) + 1;

Описания EM_LINEFROMCHAR и EM_LINEINDEX вы можете найти в файлах помощи по Windows API.

Дополнение

А можно и так, сообщает Nomadic:

var
X,Y: LongInt;
............ Y := Memo1.Perform( EM_LINEFROMCHAR, Memo1.SelStart, 0 );
X := Memo1.Parform( EM_LINEINDEX, Y, 0 );
inc( Y );
X := Memo1.SelStart - X + 1;
........

[000393]


Delphi 1

Текущая позиция Tmemo II

procedure TMyForm.BitBtn1Click(Sender: TObject);
var
iLine : Integer ;
begin
iLine := Memo1.Perform(em_LineFromChar, $FFFF, 0);
{ Примечание: первая строка нулевая }
messageDlg('Номер строки: ' + IntToStr(iLine), mtInformation,
[mbOK], 0 ) ;
end;

Роман Воробьев дополняет:

Не знаю, как было раньше (там в углу написано "Delphi 1"), но в Делфи5 у ТMemo есть св-во

property CaretPos: TPoint;

которое и решает эту проблему.

Т.е

Label1.Caption:='Строка '+IntToStr(memo1.caretpos.y);
Label2.Caption:='Столбец '+IntToStr(memo1.caretpos.x);

должно вполне работать.

По материалам книги г-на Архангельского "100 компонентов общего назначения в DELPHI 5" (за точность названия/фамилии не ручаюсь, книги под рукой нет). [000482]


Delphi 1

Сохранение Tmemo в EXE

Для того, чтобы помешать Delphi сохранять .EXE абзацы Memo в виде отдельных строк, перед тем, как загрузить текст, установите в режиме разработки свойство Memo WordWrap в False.

А во время загрузки приложения, в обработчике события формы OnCreate, установите свойство WordWrap в True. [000432]


Одной строкой

Memo в StringList и обратно

Если вам необходимо заменить все содержимое компонента Memo:

Memo1.Lines := StringList1.Strings;

Если вам необходимо добавить строки к списку компонента:

Memo1.Lines.AddStrings(StringList1.Strings);

[000457]


Одной строкой

Эквивалент вкл/выкл эха в Memo

Memo1.Perform( WM_SETREDRAW, 0, 0 );
... здесь можно добавлять строки
Memo1.Perform( WM_SETREDRAW, 1, 0 );
Memo1.Refresh;

кстати, работает во всех управляемых элементах... [000477]


Delphi 1

Использование встроенного отката в Memo

...хорошо, если интегрированный откат вас устроит, то его вы можете получить легче, чем осуществить комбинацию Ctrl+Z:

Memo1.Perform(EM_UNDO, 0, 0);

Предварительно можно осведомиться о доступности отмены (т.е. наличие предыдущих состояний) для включения/выключения соответствующего элемента меню:

Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0) <> 0;

- Neil
[000480]


Delphi 1

TMemo с row & col

Наследник TMemo со свойствами row & col:

unit C_rcmemo;

interface

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

type
TRCMemo = class(TMemo)
private
{ Private declarations }
function GetRow : Integer;
procedure SetRow(value : Integer);
function GetCol : Integer;
procedure SetCol(value : Integer);
function GetPosn : LongInt;
procedure SetPosn(value : LongInt);
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
property Row : Integer Read GetRow Write SetRow;
property Col : Integer Read GetCol Write SetCol;
property Posn : LongInt Read GetPosn Write SetPosn;
end;

procedure Register;

implementation

function TRCMemo.GetRow : Integer;
begin
Result := Perform(EM_LINEFROMCHAR, $FFFF, 0);
end;

procedure TRCMemo.SetRow(value : Integer);
begin
SelStart := GetCol + Perform(EM_LINEINDEX, Value, 0);
end;

function TRCMemo.GetCol : Integer;
begin
Result := SelStart - Perform(EM_LINEINDEX, GetRow, 0);
end;

procedure TRCMemo.SetCol(value : Integer);
begin
SelStart := Perform(EM_LINEINDEX, GetRow, 0) + Value;
end;

function TRCMemo.GetPosn : LongInt;
Var ro, co : Integer;
begin
ro := GetRow;
co := SelStart - Perform(EM_LINEINDEX, ro, 0);
Result := MakeLong(co,ro);
end;

procedure TRCMemo.SetPosn(value : LongInt);
begin
SelStart := Perform(EM_LINEINDEX, HiWord(Value), 0) + LoWord(Value);
end;

procedure Register;
begin
RegisterComponents('NJR', [TRCMemo]);
end;

end.
[000554]


Delphi 1

Ограничение размера Memo

Ограничение длины и количества строк компонента:

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Forms;

type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyPress(Sender: TObject; var Key: Char);
public
MaxCharsPerLine, MaxLines: Integer;
function MemoLine: Integer;
function LineLen(r: Integer): Integer;
function NRows: Integer;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.NRows: Integer;
begin
with Memo1 do
Result := 1 + SendMessage(Handle, EM_LINEFROMCHAR, GetTextLen-1, 0);
end;

function TForm1.LineLen(r: Integer): Integer;
var r1, r2: Integer;
begin
with Memo1 do begin
r1 := SendMessage(Handle, EM_LINEINDEX, r, 0);
if (r > NRows-1) then
r2 := SendMessage(Handle, EM_LINEINDEX, r+1, 0)-2 {-CR/LF}
else
r2 := GetTextLen;
end;
Result := r2-r1;
end;

function TForm1.MemoLine: Integer;
begin
with Memo1 do
Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MaxCharsPerLine := 8;
MaxLines := 4;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
with Memo1 do begin
case Key of
' '..#255: if (LineLen(MemoLine) >= MaxCharsPerLine) then
Key := #0;
#10, #13: if (NRows >= MaxLines) then
Key := #0;
#8: if (SelStart = SendMessage(Handle, EM_LINEINDEX, MemoLine, 0)) then
Key := #0;
end;
end;
end;

end.
[000642]


Delphi 1

Memo со своими шрифтами и др.

Кто-нибудь знает как использовать различные шрифты и стили в Memo-объекте?

Просто создайте собственный TxxxMemo: наследуйтесь от стандартного TMemo и перекройте метод Paint.

Вот мой старый пример, изменяющий цвет каждой строки:

unit Todrmemo;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TOwnerDrawMemo = class(TMemo)
private
{ Private declarations }
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
end;

procedure Register;

implementation

procedure TOwnerDrawMemo.WMPaint(var Message: TWMPaint);
var Buffer: Array[0..255] of Char;
PS: TPaintStruct;
DC: HDC;
i: Integer;
X,Y,Z: Word;
OldColor: LongInt;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
try
X := 1;
Y := 1;
SetBkColor(DC, Color);
SetBkMode(DC, Transparent);
OldColor := Font.Color;
for i:=0 to Pred(Lines.Count) do
begin
if odd(i) then SetTextColor(DC, clRed)
else SetTextColor(DC, OldColor);
Z := Length(Lines[i]);
StrPCopy(Buffer, Lines[i]);
Buffer[Z] := #0; { реально не нужно }
TextOut(DC, X,Y, Buffer, Z);
Inc(Y, abs(Font.Height));
end;
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
end;

procedure Register;
begin
RegisterComponents('Dr.Bob', [TOwnerDrawMemo]);
end;

end.

Dr. Bob (drbob@pi.net) [000683]


Delphi 1

Добавление строк в Memo

Быстро-грязный (по-русски "кривой") способ добавить в Memo дополнительный текст заключается в его загрузке в невидимый TMemo и последующем использовании следующим образом:

Memo1.Lines.AddStrings(Memo2.Lines);

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

Чтобы было по-настоящему все удобно, необходимо создать временный TMemoStrings; к сожалению, TMemoStrings определен в секции implementation файла StdCtrls.PAS, и, таким образом, нам недоступен.

Бывает и так, что два временных TStringLists удобнее одного временного TMemo. Например, такой случай:

TS1 := TStringList.Create;
TS2 := TStringList.Create;
TS1.Assign(Memo1.Lines);
Memo1.Lines.LoadFromFile('BULLRUN.TXT');
TS2.Assign(Memo1.Lines);
Memo1.Lines.Assign(TS1);
Memo1.Lines.AddStrings(TS2);
TS2.Free;
TS1.Free;

Уф!! Гвоздь программы здесь - возможность разрывать строки в свойстве Memo Lines при добавлении НОВОГО текста. Итак, мы записываем существующий текст во временную переменную, считываем новый текст в Memo, снова передаем НОВЫЙ текст временной переменной, восстанавливаем оригинальный текст и, наконец, добавляем новый текст.

- Neil J. Rubenking [000802]


Delphi 1

Обнаружение прокрутки TMemo

Создайте потомок TMemo, перехватывающий сообщения WM_HSCROLL и WM_VSCROLL:

TSMemo = class(TMemo)
procedure WM_HScroll(var Msg: TWMHScroll); message WM_HSCROLL;
procedure WM_VScroll(var Msg: TWMVScroll); message WM_VSCROLL;
end;

..

procedure TSMemo.WM_HScroll(var Msg: TWMHScroll);
begin
ShowMessage('HScroll');
end;

procedure TSMemo.WM_VScroll(var Msg: TWMVScroll);
begin
ShowMessage('VScroll');
end;

- Xavier Pacheco [000803]


Вставка текста в TMemo

Как мне вставить какой-либо текст в TMemo в позицию курсора (во время выполнения программы)?

Прямого метода в Delphi не существует, но можно воспользоваться сообщениями Windows:

Delphi 2.0:

SendMessage(Memo.Handle, EM_REPLACESEL, 0, PCHAR('Текст'));

В Delphi 1.0 вы не сможете просто так преобразовать строку в Pchar, поэтому вам следует сделать следующее:

Var TempBuf :Array [0..255] of Char;
SendMessage(Memo.Handle, EM_REPLACESEL, 0, StrPCopy(TempBuf,'Текст'));

Имейте в виду, что это ЗАМЕНЯЕТ любой выбранный текст. Если вам нужно этого избежать, присвойте предварительно свойству Delphi Memo.SelLength 0.

- Dave Berg [000924]


Delphi 2

Управление прокруткой Memo

У меня имеется компонент TMemo, и мне необходимо автоматически "тормозить" программным способом его прокрутку при добавлении новой строки Memo.Lines.Add(Строка).

В Delphi 2.0 простая установка 'SelStart:=0' НЕ срабатывает. Это ошибка в коде VCL. Значения различных частей 'сообщения' windows, используемые для "set selection" (установления выбранной части текста) в WIN32 были изменены (это использовалось для 'автоматической' прокрутки каретки/курсора, но больше не работает).

Попробуйте добавить следующую строку ПОСЛЕ 'SelStart:=0;':

SendMessage(Handle,EM_SCROLLCARET,0,0);

Это должно заставить компонент работать так, как вы и ожидаете. Я надеюсь что Borland знает об этой проблеме и скоро ее исправит.

Здесь я должен пояснить, что ошибка как раз не в самом TMemo, а в TCustomEdit (в методе SetSelLength в stdctrls.pas). Поэтому данная проблема может наблюдаться во всех наследниках TCustomEdit (как TMemo).

- Bob Sherman [000954]


Импортирование файла в компонент Memo

Как мне импортировать файл в элемент управления TMemo начиная с позиции курсора? LoadFromFile заменяет содержимое TMemo содержимым текстового файла. Я хочу включить текстовый файл или в поцизию курсора или, если выбран текст, заменить этот текст содержимым текстового файла. Все это должно быть похоже на работу фунции PasteFromClipboard.

Самый простой путь вставки текста в компонент Memo заключается в посылке ему сообщения EM_REPLACESEL.

{ InsertFileInMemo--
ПРИМЕЧАНИЕ: если вы хотите заменить к настоящему времени
выбранный в Memo текст, передайте в параметре ReplaceSel
TRUE. FALSE необходим для простой вставки текста... }
procedure InsertFileInMemo( Memo: TMemo; FileName: string;
ReplaceSel: Boolean );
var
Stream: TMemoryStream;
NullTerminator: Char;
begin
Stream := TMemoryStream.Create;
try
{ Загружаем текст... }
Stream.LoadFromFile( FileName );

{ Добавляем в конец текста терминирующий ноль... }
Stream.Seek( 0, 2 );
NullTerminator := #0;
Stream.Write( NullTerminator, 1 );

{ Вставляем текст в Memo... }
if not ReplaceSel then Memo.SelLength := 0;
SendMessage( Memo.Handle, EM_ReplaceSel, 0,
LongInt( Stream.Memory ));
finally
Stream.Free;
end;
end;

- Ed Jordan [001000]


Delphi 1

События OnClick/Onchange компонента Notebook

Я задавал этот вопрос. Когда я сначала "увидел" событие OnClick, я подумал что он возникает перед OnChange.

:::неправильное предположение:::

Проверьте TabbedNotebook на наличие события OnClick. Он возникает после события OnChange.

[000400]


Delphi 1

Создание страниц компонента Notebook во время работы приложения

procedure TForm1.Button1Click(Sender: TObject);
Var
NewPage:   TWinControl;
begin
TabbedNotebook1.Pages.Add (Edit1.Text);
NewPage := TabbedNotebook1.Pages.Objects [TabbedNotebook1.Pages.Count - 1]
as TWinControl;
With TLabel.Create (Self) do begin
Left := 20;
Top  := 20;
Caption := '&Телефон: ';
Parent := NewPage;
end;
With TEdit.Create (Self) do begin
Left := 100;
Top  := 20;
Text := '1-800-555-1212';
Parent := NewPage;
end;
end;
[000454]


Delphi 1

Итерация элементов управления компонента Notebook

Вот две малениких процедурки, присваивающие заголовкам всех компонентов Label на всех страницах компонента NoteBook значение 'Foo'. (Я вам не говорил, что это будет ПОЛЕЗНЫМ примером!)

procedure TForm1.Button1Click(Sender: TObject);
VAR M, N : Word;
begin
FOR N := 0 TO TabbedNotebook1.Pages.Count-1 DO
WITH TabbedNotebook1.pages.Objects[N] AS TTabPage DO
FOR M := 0 TO ControlCount-1 DO
IF Controls[M] IS TLabel THEN
WITH Controls[M] AS TLabel DO
Caption := 'Foo';
end;

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
Notebook1.PageIndex := TabSet1.TabIndex;
end;

procedure TForm1.Button2Click(Sender: TObject);
VAR M, N : Word;
begin
FOR N := 0 TO TabbedNotebook1.Pages.Count-1 DO
WITH Notebook1.pages.Objects[N] AS TPage DO
FOR M := 0 TO ControlCount-1 DO
IF Controls[M] IS TLabel THEN
WITH Controls[M] AS TLabel DO
Caption := 'Foo';

end;
[000520]


Delphi 1

Проблема с освобождением ресурсов Notebook

Проблема с использованием ресурсов в компоненте Notebook? Вы можете обойти это, освобождая дескрипторы окон невидимых страниц компонента. Следующий код поясняет как это можно сделать - я создал обработчик события компонента OnClick, освобождающий дескрипторы невидимых страниц при каждом изменении видимой страницы:

procedure TForm1.TabSet1Click(Sender: TObject);
var i : integer ;
begin
Notebook1.PageIndex := TabSet1.TabIndex ;
with Notebook1, Pages do for i := 0 to Count - 1 do
if (i <> PageIndex) then TForm1(Objects[i]).DestroyHandle ;
end;

Как вы могли заметить, я привел тип страницы notebook (Objects[ i ]) к объектам TForm1, что на самом деле не так. Тем не менее, эта небольшая хитрость позволяет иметь доступ к защищенным членам извне метода класса, где они определены, в данном случае DestroyHandle - защищенный метод TWinControl.

Это работает, поскольку TForm1 является наследником TWinControl, и позволяет иметь доступ к защищенным членам TForm1 и ее наследникам. Быстро и грязно, но это работает! <g>

Не волнуйтесь, если вы видите, что невидимая страница показывается снова. VCL - довольно умная штука, поскольку захватывает данные от дескриптора окна и сохраняет это непосредственно в объекте. Затем, всякий раз, когда дескриптор требуется снова, то есть тогда, когда вы делаете страницу видимой, дескриптор окна пересоздается, туда снова копируются данные, и оп-ля, как будто ничего и не произошло - магия!

Я надеюсь это поможет.

Mike Scott. [000616]


Delphi 1

Notebook как контейнер для форм I

...у меня происходит утечка памяти при изменениях страниц в закладках NoteBook.

Вы не "теряете" ресурсы, вы их используете. Вы ИСПОЛЬЗУЕТЕ ресурсы на каждой страницы начиная с первой, которая доступна для вашего созерцания. Я упомянаю это потому, потому что проблема ПОТЕРИ ресурсов относится к другому типу проблемы.

Недавно я работал над проблемой показа других *ФОРМ* в главной форме, как если бы они были страницами NoteBook. Форма создается при перелистывании на эту "страницу", и разрушается при ее покидании. Это требует хранения неизменяемой информации, естественно, в главной форме, но это чрезвычайно нетребовательно к ресурсам. Главное, что вы храните поля индивидуальных данных в главной форме с именем "Child", а инициализируете в обработчике события экземпляра TForm2 (или имеющего другое имя, в зависимости от имени вашей первой дочерней формы) OnCreate. Поместите закладки в нижней части формы, и при изменении закладки освобождайте текущего "ребенка", а затем создавайте и делайте ребенком другой соответствующий экземпляр формы.

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

PROCEDURE TPageForm.CreateParams(VAR Params: TCreateParams);
BEGIN
Inherited  CreateParams(Params);
WITH Params DO
BEGIN
WndParent := Application.MainForm.Handle;
Parent := Application.MainForm;
Style := WS_CHILD OR WS_CLIPSIBLINGS OR WS_CLIPCHILDREN;
Align := alClient;
END;
END;

Код главной формы должен выглядеть примерно так:

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
LockWindowUpdate(Handle);
Child.Free;
CASE NewTab OF
0 : Child := TForm2.Create(Application);
1 : Child := TForm3.Create(Application);
2 : Child := TForm4.Create(Application);
END;
Child.Show;
LockWindowUpdate(0);
end;

Надеюсь это окажется полезным!

- Neil [000664]


Delphi 1

Notebook как контейнер для форм II

Кто-нибудь может мне помочь в вопросе размещения подклассов форм на страницах компонента TTabbedNotebook?

Я пробовал следующий код и он отлично работает с компонентами, являющимися частью формы, содержащей TTabbedNotebook; тем не менее он не работает с дочерними формами:

ChildForml[i].Parent := TWinControl(BrowseTabNotebook.Pages.Objects[i]);

В дочерней форме должен быть следующий код:

private { Private-Deklarationen }
procedure CreateParams(var Params: TCreateParams); override;

...

procedure TChildForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);    { сначала вызываем унаследованные методы. }
with Params do begin
WndParent := Application.Mainform.Handle;
Style := (Style or WS_CHILD) and not WS_POPUP;
end;
end;

- Ralph Friedman [000823]


Delphi 1

Notebook - добавление и удаление страниц

Как во время выполнения программы динамически добавлять и удалять страницы динамически созданного NoteBook?

procedure AddPage(nbk : TNotebook; tabset : TTabSet; const pagename :string);
{ Добавляем новую страницу к NoteBook и новую закладку к tabset (параметр pagename задает имя страницы), размещаем на странице компонент Memo и выводим новую страницу на передний план. Подразумевается, что TabSet (набор закладок) имеет ровно по одной закладке на каждую страницу NoteBook с точным сохранением порядка. }
var
memo : TMemo;
page : TPage;
begin
if nbk <> nil then begin
nbk.Pages.Add(pagename);                           {добавляем страницу в TNotebook}
nbk.PageIndex := nbk.Pages.Count - 1;              {делаем новую страницу текущей}
if tabset <> nil then begin
tabset.Tabs.Add(pagename);                      {добавляем соответствующую закладку}
tabset.TabIndex := nbk.PageIndex;               {делаем новую закладку текущей}
end;
if nbk.PageIndex > -1 then begin                    {убедимся что страница существует}
page := TPage(nbk.Pages.Objects[nbk.PageIndex]); {получаем объект страницы}}
memo := TMemo.Create(page);                      {создаем TMemo (и страницей в качестве родителя)}
try
memo.Parent := page;                            {устанавливаем страницу в качестве Parent}
memo.Align  := alClient;                        {устанавливаем выравнивание для заполнения области клиента}
except
memo.Free;                                      {освобождаем TMemo, если что-то идет неправильно}
end;
page.Visible := true;                             {показываем страницу}
end;
end;
end;

procedure DeletePage(nbk : TNotebook; tabset : TTabSet; index : integer);
{ Удаляем страницу, чей PageIndex = index из nbk и tabset. Подразумевается, что TabSet имеет ровно по одной закладке на каждую страницу NoteBook с точным сохранением порядка. }
var
switchto : integer;
begin
if nbk <> nil then begin
if (index >= 0) and (index < nbk.Pages.Count) then begin
if index = nbk.PageIndex then begin
if index < nbk.Pages.Count - 1 then begin      {если страница не последняя в списке}
switchto := nbk.PageIndex;                    {выводим страницу за текущей, ставшей ею после удаления}
if (index = 0) and (nbk.Pages.Count > 1) then {если первая страница}
nbk.PageIndex := 1;                         {теперь показываем вторую страницу}
end else
switchto := nbk.PageIndex - 1;                {в противном случае показываем страницу, расположенную перед текущей}
end;
nbk.Pages.Delete(index);                          {освобождаем страницу и все принадлежавшие ей элементы управления}
if tabset <> nil then begin
if index < tabset.Tabs.Count then
tabset.Tabs.Delete(index);                    {удаляем соответствующую закладку}
end;
nbk.PageIndex := switchto;
end;
end;
end;

--Mark Johnson [000800]


Delphi 1

Включение/Выключение закладки Notebook

Вот хороший трюк от Xavier Pacheco:

unit TabDis;

interface

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

type
TFrmTabDis = class(TForm)
TabbedNotebook1: TTabbedNotebook;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;

var
FrmTabDis: TFrmTabDis;

implementation

{$R *.DFM}

procedure TFrmTabDis.FormCreate(Sender: TObject);
var
i: integer;
j: integer;
begin
{ Создаем имена для всех Notebook TTabButton }

j := 0;

with TabbedNotebook1 do
for i := 0 to ControlCount - 1 do
if Controls[i].ClassName = 'TTabButton' then begin
Controls[i].Name := Controls[i].ClassName + IntToStr(j);
Inc(j);
end;
end;

procedure TFrmTabDis.Button1Click(Sender: TObject);
begin
{ Делаем недоступной определенную страницу notebook }
with TControl(TabbedNotebook1.FindComponent('TTabButton2')) do
Enabled := not Enabled;
end;

end.

- Ralph Friedman [000952]


Delphi 1

TPaintBox в буфер обмена
var
pbRect: TRect; begin
pbRect := Rect(0, 0, PaintBox1.Width, PaintBox1.Height);
BitMap := TBitMap.Create;
try
Bitmap.Width := PaintBox1.Width;
Bitmap.Height := PaintBox1.Height;
BitMap.Canvas.CopyRect(pbRect, PaintBox1.Canvas, pbRect);
ClipBoard.Assign(BitMap);
finally
BitMap.Free;
end; end;

- Xavier Pacheco [000824]


Delphi 1

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

Если установлен стиль otOwnerDraw, вы можете сами отрисовывать компонент. В этом режиме вы можете вывести какие угодно изображения. Примечание: чтобы получить OwnerDraw для работы, вы должны установить свойство Scrollbar в vsVertical.

Затем обрабатывайте событие OnDrawItem для рисования каждой строчки OutLine.

Для получения правильного индекса узла используйте GetItem(Rect.Left, Rect.Top). Индекс в drawItem неверен.

Вот пример из моего приложения. Надеюсь это вам поможет.

procedure TfrmMain.Outline2DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var Node: TOutlineNode;
NodeIdx: Integer;
Offset: Integer;
NowBitmap: TBitmap;
NowAstValue: String;
begin
NodeIdx := Outline2.GetItem(Rect.Left, Rect.Top);
Node := Outline2.Items[NodeIdx];
NowAstValue := PAstRec(Outline2.Items[NodeIdx].Data)^.AstValue;
with Outline2.Canvas do begin
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Offset := MulDiv(Font.Size, 150, 100);
fillRect(Rect);
Rect.Left := Rect.Left + ((Node.Level - 1) * Offset + 2);
if Node.HasItems then
begin
if Node.Expanded then
NowBitmap := Outline2.PictureMinus
else
NowBitmap := Outline2.PicturePlus;
{рисуем иконку}
BrushCopy(Rect, NowBitmap,
Bounds(0,0, Rect.Right - Rect.Left, Rect.Bottom -
Rect.Top),
NowBitmap.TransparentColor);
end;
Rect.Left := Rect.Left + Offset + 2;
{выводим текст}
TextOut(Rect.left, Rect.Top, Node.Text);
{создаем суммирующую колонку с правым выравниванием}
Rect.Left := Rect.Right - TextWidth(NowAstValue)- 2;
TextOut(Rect.Left, Rect.Top, NowAstValue);
end;

-Craig Osterloh

А как работает функция PAstRec() и как получить указатель на данные?

Вот код:

function TfrmMain.LoadAssetNodes(fName: String; header: String): Double;
var headerIdx: Integer;
NowClientID: String;
TotAssetValue: Double;
AstRecPtr: PAstRec;
sqlText: String;
HeadPtr: PAstRec;
begin
with qryAssets do begin
NowClientID := dtbClients.Fields[0].AsString;
sqlText := 'Select * from ' + fName + ' where ClientID = ' +
NowClientID;
SQL.Clear;
SQL.Add(sqlText);
Open;
First;
TotAssetValue := 0;
new(HeadPtr);
headerIdx := outAssets.AddObject(0, header, HeadPtr);
while not EOF do begin
new(AstRecPtr);
AstRecPtr^.AstValue := format('%8.0n',
[FieldByName('AssetValue').AsFloat]);
TotAssetValue :=
TotAssetValue + FieldByName('AssetValue').AsFloat;
outAssets.AddChildObject(headerIdx,
FieldByName('AssetName').AsString,
AstRecPtr);
Next;
end;
HeadPtr^.AstValue := format('%8.0n',[TotAssetValue]);
Result := TotAssetValue;
end;
end;

-Craig Osterloh
[000475]


Delphi 1

TOutLine drag & drop
Один из наших сотрудников разработал механизм "drag and drop" (перетащи и брось) для двух компонентов TOutline. Вот дословно его произведение:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Outline1: TOutline;
Outline2: TOutline;
procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
with Sender as TOutline do
begin
AddChild(GetItem(x,y),
TOutline(Source).Items[TOutline(Source).SelectedItem].Text);
end;

end;

procedure TForm1.OutlineMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
with Sender as TOutline do
begin
if GetItem(x,y) >= 0 then
BeginDrag(False);
end;
end;

procedure TForm1.OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Source is TOutline) and (TOutline(Source).GetItem(x,y) <> TOutline(Source).SelectedItem)
then
Accept := True
else
Accept := False;

end;

end.

Я надеюсь это поможет.

Lloyd Linklater <Sysop>
Delphi Technical Support [000594]


Delphi 1

TOutline OwnerDraw - значение индекса

Тема: Компонент Outline
От: Blake Versiga 73123,2737
К: Steve Dunn 74343,1373

Параметр TheOutline Index в обработчике OwnerDraw всегда равен нулю.

{ получаем значение Index узла, который нужно отрисовать}
ItemIndex := Outline1.GetItem(Rect.Left, Rect.Top);

{Получаем узел Ouline }
Node := Outline1.Items[ItemIndex];

Blake Versiga [000721]


Delphi 1

Пример отрисовки TOutline

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

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

procedure TForm1.FormCreate(Sender: TObject);
begin
BitmapPlus :=TBitmap.Create;
BitmapPlus.LoadFromFile('c:\delphi\images\default\outplus.bmp');
BitmapMinus:= TBitmap.Create;
BitmapMinus.LoadFromFile('c:\delphi\images\default\outminus.bmp');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
BitMapPlus.Destroy;
BitMapMinus.Destroy;
end;

procedure TForm1.Outline1DrawItem(Control:TWinControl; Index:Integer;  Rect:TRect; State:TOwnerDrawState);
var
iLeft, iht: integer;
s: string;
NodeInView: TOutlineNode;
col: TColor;
{Примечание: BitMapvariables BitMapPlus и .. Минус объявлены глобально и грузятся при создании формы}
begin
with (Control as TOutline).Canvas do begin
{рисуем на холсте элемента управления, не на форме}
IndexInFull := outline1.getitem(rect.left+1,rect.top+1);
NodeInView := Outline1.Items[IndexInFull];
Font := Outline1.Font;
iLeft := Rect.Left;
iht := Outline1.ItemHeight;
inc(iLeft, iht*(NodeInView.level-1));
s := NodeInView.Text;
Col := clWindow;
Font.Color := clWindowText;
Brush.Color := col;
FillRect(Rect);     { очищаем прямоугольник }
if NodeInView.HasItems and not NodeInView.Expanded then
{Draw(iLeft,Rect.Top, BitmapPlus)}
BrushCopy(Bounds(iLeft+1,Rect.Top+1,iht-2,iht-2),BitMapPlus,
Bounds(0,0,BitMapPlus.Width,BitMapPlus.Height),
BitMapPlus.TransparentColor);
if NodeInView.Expanded and NodeInView.HasItems then
BrushCopy(Bounds(iLeft+1,Rect.Top+1,iht-2,iht-2),BitMapMinus,
Bounds(0,0,BitMapMinus.Width,BitMapMinus.Height),
BitMapMinus.TransparentColor);
if Copy(NodeInView.Text,Length(NodeinView.Text),1)='y'  then Col := clAqua;
if Outline1.SelectedItem = IndexInFull then begin
Col := clHighlight;
Font.Color := clHighlightText
end;
Brush.Color := col;
inc(ILeft,iht);
TextOut(iLeft, Rect.Top, s);
end;
end;

- David E. Scheim [000783]


Поточность TOutline

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

Ниже приведен простейший путь решения вашего вопроса. Имейте в виду, что в коде не предусмотрена проверка на ошибки чтения и гарантии принадлежности компонента типу TOutline.

procedure TForm1.Button2Click(Sender: TObject);
var
S: TFileStream;
begin
S := TFileStream.Create('C:\junk\myoutlin.dat', fmCreate);
try
S.WriteComponent(Outline1);
finally
S.Free;
end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
S: TFileStream;
begin
S := TFileStream.Create('C:\junk\myoutlin.dat', fmOpenRead);
try
S.ReadComponent(Outline1);
finally
S.Free;
end;
end;

- Nick Hodges [000949]


Перемещение мышью панели на форме во время выполнения программы

Прислал Aleksey msalex@tomcat.ru:

{Так можно таскать мышкой TPanel по форме в run-time'е.
Поместите на форму TPanel и напишите обработчик события OnMauseDown,
запустите программу и задвинте эту панель подальше.}

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DRAGMOVE = $F012;
begin
ReleaseCapture;
Panel1{а если сюда написать Form1, то можно таскать форму по экрану}.Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;

В.О.: на самом деле таким образом можно таскать по форме любые визуальные компоненты. [000116]


Панель с изменяющимися размерами

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

unit Elastic;

interface

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

type
TElasticPanel = class( TPanel )
private
FHorz, FVert: boolean;
nOldWidth, nOldHeight: integer;
bResized: boolean;
protected
procedure WMSize( var message: TWMSize ); message WM_SIZE;
public
nCount: integer;
constructor Create( AOwner: TComponent ); override;
published
property ElasticHorizontal: boolean read FHorz write FHorz default
TRUE;
property ElasticVertical: boolean read FVert write FVert default
TRUE;
end;

procedure Register;

implementation

constructor TElasticPanel.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
FHorz := TRUE;
FVert := TRUE;
nOldWidth := Width;
nOldHeight := Height;
bResized := FALSE;
end;

procedure TElasticPanel.WMSize( var message: TWMSize );
var
bResize: boolean;
xRatio: real;
i: integer;
ctl: TWinControl;
begin
Inc( nCount );
if Align = alNone then
bResize := TRUE
else
bResize := bResized;
if not ( csDesigning in ComponentState ) and bResize then
begin
if FHorz then
begin
xRatio := Width / nOldWidth;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl( Controls[i] );
ctl.Left := Round( ctl.Left * xRatio );
ctl.Width := Round( ctl.Width * xRatio );
end;
end;
if FVert then
begin
xRatio := Height / nOldHeight;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl( Controls[i] );
ctl.Top := Round( ctl.Top * xRatio );
ctl.Height := Round( ctl.Height * xRatio );
end;
end;
end
else
begin
nOldWidth := Width;
nOldHeight := Height;
end;
bResized := TRUE;
nOldWidth := Width;
nOldHeight := Height;
end;

procedure Register;
begin
RegisterComponents('Additional', [TElasticPanel]);
end;

end.
[000315]


Компонент со вложенной панелью

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

unit RzPnlPnl;

interface

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

type
TSubPanel = class(TPanel)
protected
procedure ReadState( Reader : TReader ); override;
end;

TPanelPanel = class(TPanel)
private
FSubPanel : TSubPanel;
protected
procedure WriteComponents( Writer : TWriter ); override;
procedure ReadState( Reader : TReader ); override;
public
constructor Create( AOwner : TComponent ); override;
end;

procedure Register;

implementation

procedure TSubPanel.ReadState( Reader : TReader );
var
OldOwner: TComponent;
begin
OldOwner := Reader.Owner;      { Сохраняем старого владельца, что необходимо для PanelPanel }
Reader.Owner := Reader.Root;   { Задаем в качестве владельца форму }
try
inherited ReadState(Reader);
finally
Reader.Owner := OldOwner;
end;
end;

constructor TPanelPanel.Create( AOwner : TComponent );
const
Registered: Boolean = False;
begin
inherited Create( AOwner );

FSubPanel := TSubPanel.Create( Self );
FSubPanel.Parent := Self;
FSubPanel.SetBounds( 20, 20, 200, 100 );
FSubPanel.Name := 'SomeName';

if not Registered then
begin
Classes.RegisterClasses([TSubPanel]);    { так TSubPanel может храниться в файле формы }
Registered := True;
end;

end;

procedure TPanelPanel.ReadState( Reader : TReader );
var
OldOwner: TComponent;
I: Integer;
begin
for I := 0 to ControlCount - 1 do
Controls[ 0 ].Free;

OldOwner := Reader.Owner;
Reader.Owner := Self;  {Для чтения субкомпонентов, установите данный экземпляр в качестве родителя}
try
inherited ReadState(Reader);
finally
Reader.Owner := OldOwner;
end;
end;

procedure TPanelPanel.WriteComponents( Writer : TWriter );
var
I: Integer;
begin
for I := 0 to ControlCount - 1 do
Writer.WriteComponent(Controls[I]);
end;

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

end.

- Ray Konopka [000947]


Как динамически создавать пункты подменю в PopupMenu

Примерно так:

procedure TForm1.PopupMenu2Popup(Sender: TObject);
var
mi, msub: TmenuItem;
begin
with (Sender as TPopupMenu) do begin
// Удаляем все пункты меню

// while Items.Count > 0 do Items.delete(0);
// Предыдущий код имел утечку памяти. Коррекция от Andrew Stewart (astewart@Strobes.co.nz)
while Items.Count > 0 do Items[0].Free;

// Создаем обычный пункт "Первый"
mi := TMenuItem.Create(self);
with mi do begin
Caption := 'Первый';
OnClick := MyClick;
end;
Items.Insert(0, mi);

// Создаем подменю "Подменю" c двумя пунктами "Подменю1" и
// "Подменю2"
mi := TMenuItem.Create(self);
with mi do begin
Caption := 'Подменю';
msub := TMenuItem.Create(self);
with msub do begin
Caption := 'Подменю1';
OnClick := MyClick;
end;
Insert(0, msub);

msub := TMenuItem.Create(self);
with msub do begin
Caption := 'Подменю2';
OnClick := MyClick;
end;
Insert(1, msub);
end;
Items.Insert(1, mi);
end;
end;

procedure TForm1.MyClick(Sender: TObject);
begin
beep;
end;
[000174]


Динамическое создание пункта меню в PopupMenu

Кто-нибудь может просветить меня по этому вопросу?

Решение 1

Procedure TTypeOfFrame.CreateAPopUpMenu;
var
NewItem: TMenuItem;
FDragEnabledPopUpMenu : TPopUpMenu;
begin
NewItem := TMenuItem.Create(Self);
NewItem.Caption := 'Пункт меню';
FDragEnabledPopUpMenu:= TPopUpmenu.Create(Self);
with FDragEnabledPopUpMenu do
begin
Items.Add(NewItem);
end;
end;

Решение 2

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

procedure MyClick(Sender : TObject);

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

NewItem := TMenuItem.Create(Self);
NewItem.Caption := 'Пункт меню';
NewItem.OnClick := MyClick;

[000136]


Delphi 1

Как вызвать PopupMenu?

Я создал общий обработчик события для всех моих компонентов EditBox. Моя проблема заключается в том, что в обработчике при нажатии правой кнопки мыши мне нужно вызвать PopupMenu, создать список доступных значений, отметить текущее и вернуть обратно в EditBox выбранное, т.е. мне нужна двухсторонняя связь.

Это хороший кандидат в Delphi FAQ. Вот небольшой совет, который я недавно кому-то давал (извините, забыл кому):

Добавьте объявление переменной в секцию private вашей формы:

ActivePopUp : TPopUpMenu;

Затем укажите в обработчике события OnPopUp на общий TPopUpMenu как показано ниже:

procedure TForm1.OnPopUp (Sender: TObject);
begin
ActivePopUp := Sender as TPopUpMenu;
end;

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

ActivePopUp.PopUpComponent

-TonyT. [000725]


Delphi 1

Обработчик динамически созданного пункта меню

Как мне "подключить" код к пункту меню, который был создан динамически?

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

unit Tunit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;         { Просто "место для щелчка" и отображения результатов }
procedure Edit1Click(Sender: TObject);
private
{ Private declarations }
FPopupMenu: TPopupMenu;  { Общий Popup для использования "кем нужно" }
FPopupResult: Longint;   { Результат последнего выполненного FPopupMenu }
procedure FPopupMenuClick(Sender: TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FPopupMenuClick(Sender: TObject);
begin
with (Sender as TMenuItem) do
FPopupMenu.Tag := Tag;     { передаем значение TMenuItem.Tag в FPopupMenu.Tag }
end;

procedure TForm1.Edit1Click(Sender: TObject);
var
tx,ty,tz: integer;
FMenuItem: TMenuItem;
begin
tx := Left + (Width - ClientWidth) + (Sender as TEdit).Left;
ty := Top + (Height- ClientHeight)+ (Sender as TEdit).Top;
FPopupMenu:= TPopupMenu.Create(Self);
FPopupMenu.AutoPopup := false;
FPopupMenu.Tag := 0;
for tz := 1 to 5 do
begin
FMenuItem := TMenuItem.Create(Self);
with FMenuItem do
begin
Tag := tz;
OnClick := FPopupMenuClick;          { все сделает один OnClick }
Caption := 'Выбор #'+IntToStr(tz);
end;
FPopupMenu.Items.Add(FMenuItem)
end;
FPopupMenu.Popup(tx,ty);
Application.Processmessages;   { даем время для обработки события OnClick }
if FPopupMenu.Tag<>0 then       { они действительно выбрали что-то ? }
begin
FPopupResult:= FPopupMenu.Tag;
Edit1.Text := ' Выбор #'+IntToStr(FPopupResult);
end;
{ FPopupMenu.Tag может храниться в ГЛОБАЛЬНОЙ переменной и использоваться
позже как порядковое значение в блоках CASE OF или IF THEN
для организации в коде условного перехода. }
FPopupMenu.Free;
FPopupMenu:= nil;
end;

end.

- Dennis Passmore [000730]


Delphi 1

Использование контекстного меню с VBX

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

Как мне перехватить это?

Например, так:

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button = mbRight then
with (Sender AS TControl) do
with ClientToScreen(Point(X,Y)) do
begin
PopupMenu1.PopupComponent := TComponent(Sender);
PopupMenu1.Popup(X,Y);
end;
end;

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

[000839]


Вызов контекстного меню в позиции курсора

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

Это будет работать:

procedure TForm1.Form1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbRight then
with ( Sender as TControl ).ClientToScreen( Point( X, Y )) do
PopupMenu1.Popup( X, Y );
end;

- Ed Jordan [000953]


ProgressBar в StatusBar?

Здравствуйте Валентин!

Некоторое время назад была у меня проблема: как вставить ProgressBar в StatusBar?
Не помню где в инете, но я нашел такое решение (мне очень понравилось):

var
pb: TProgressBar;

begin
....
pb:= TProgressBar.Create(self);
with pb do begin
Parent:= StatusBar1;
Position:= 30;
Top:= 2;
Left:= 0;
Height:= StatusBar1.Height - Top;
Width:= StatusBar1.Panels[0].Width - Left;
end;  //with;
pb.Visible:= True;
....
end;

Может и Вам понравится.

Алексей Лихолетов
alicho@go.ru [000490]


Поиск записи с помощью TQuery I

Как мне найти запись (осуществить '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;

[000247]


Delphi 1

Поиск записи с помощью TQuery II

Компонент 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;

Данная функция требует три параметра:

  1. AQuery: тип TQuery; компонент TQuery, в котором необходимо выполнить поиск.
  2. AField: тип String; имя поля, с величиной которого проиходит сравнение значение поиска.
  3. AValue: тип String; искомая величина. Если поля имеет тип отличный от типа String, искомая величина должна быть преобразована к типу данных.
Возвращаемая логическая величина указывает на успешность выполнения функции (True) или отсутствие результата поиска (False).

Альтернативой служит использование метода заключения в скобки. На концептуальном уровне данный метод действует отчасти подобно индексу bb-дерева. Он основывается на методе сравнения значения текущей строки набора данных и искомой величины с последующей проверкой на выполнение одного из трех возможных условий:

  1. Величина поля будет больше чем значение поиска, или...
  2. Величина поля будет меньше чем значение поиска, или...
  3. Величина поля равняется значению поиска.
Данный метод сужает область данных, отбрасывая при каждой итерации записи, не удовлетворяющие приведенным выше условиям до тех пор, пока первые два условия выполняться не будут. Полученные данные сравнивается с искомой величиной и, если они совпадают, считается что функция выполнена успешно (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 и менее строк), метод последовательного поиска все же будет быстрее. [000589]


Delphi 1

Ограничения C/S TQuery

Так вы утверждаете что я не могу иметь более одного TQuery (с открытым курсором) во время выполнения приложения???

Мы разрабатываем приложение для работы с Oracle при помощи Borland Delphi, который как раз и не позволяет иметь несколько TQuery. У нас есть программа с пятью вложенными курсорами. Нам пришлось преобразовать это в хранимые процедуры и пока это работает хорошо. Мы работали с PowerBuilder (который позволял оперировать только четырьмя вложенными курсорами) и пробовали работать с другими большими корпоративными средами, но остановились на Delphi по ряду причин, хотя и пришлось смириться с возможностью иметь дело только с одним TQuery. Borland наверняка знает об этой проблеме и исправит ее в Delphi 2. [000496]


Чтение текста RichEdit из базы данных

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

procedure ReadRichEditFromTable(Table : TTable; var RichEdit : TRichEdit);
var
BlobStream : TBlobStream;
begin
try
BlobStream := TBlobStream.Create(Table.FieldByName('BODY') as TBlobField, bmRead);
if (not Table.FieldByName('BLOBFieldName').IsNull) then
begin
RichEdit.Lines.LoadFromStream (BlobStream);
end;
finally
BlobStream.Free;
end;
end;

Спасибо Сергею Лагонскому за ценные замечания. [000231]


Подсчет слов в Richedit

Кто нибудь знает как посчитать количество слов в компоненте RichEdit??

Кто-то положил это в эхотаг несколько недель назад. Я попробовал это и это, кажется, работает.

function GetWord: boolean;
var s: string; {предположим что слова не содержат>255 символов}
c: char;
begin
result:= false;
s:= ' ';
while not eof(f) do
begin
read(f, c);
if not (c in ['a'..'z','A'..'Z'{,... и т.д, и т.п.}]) then break;
s:=s+c;
end;
result:= (s<>' ');
end;
procedure GetWordCount(TextFile: string);
begin
Count:= 0;
assignfile(f, TextFile);
reset(f);
while not eof(f) do if GetWord then inc(Count);
closefile(f);
end;

[000232]


Delphi 2

Ошибка RichEdit в Delphi 2.01 под NT 4

Я написал программу, передающую невидимому RichEdit введенную пользователем с помощью кнопок и нескольких checkbox (кнопки с независимой фиксацией) информацию. Программа разрабатывалась и эксплуатировалась под Windows 95 и работала без проблем. Но под NT 4.0 строка ...

RichEdit1.Print('');

возвращала ошибку "Divide by Zero" (деление на ноль). Единственный выход из создавшегося положения заключался в сохранении файла c последующей его загрузкой и печатью с помощью MS Word.

Кому-нибудь приходилось решать эту проблему?

Да, я знаю что нужно сделать...

Чтобы решить эту проблему, необходимо небольшое хирургическое вмешательство в VCL модуль ComCtrls.pas.

Я протестировал исправленный код на большинстве платформ, в том числе на NT 4.0 и Win95, и, кажется, все работает как положено. На самом деле это легко исправить, только нужно знать где...

{
Существует проблема совместимости при вызове оригинального метода RichEdit.Print
под NT 4.0. Исключительная ситуация EDivByZero происходит из-за того,
что свойство Printer.Handle вне блока BeginDoc/EndDoc под NT 4.0
возвращает дескриптор информационного контекста (Information Context - IC) вместо
дескриптора контекста устройства (Device Context - DC). EM_FORMATRANGE пытается использовать этот IC
вместо реального DC принтера, вызывая этим исключительную ситуацию. Если свойство Handle
акцептуется ПОСЛЕ BeginDoc, дескриптор контекста устройства возвращает истину,
что и было мною исправлено в коде. Я оставил на том же месте в коде оригинальное
месторасположение вызова BeginDoc, при этом сделав соответствующий комментарий
для указания на внесенные изменения.
}
 procedure TCustomRichEdit.Print(const Caption: string);
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY: Integer;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Printer, Range do
begin
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
// Спозиционированный вызов BeginDoc для обеспечения
// совместимости под NT 4.0 и Win95
BeginDoc;
hdc := Handle;
hdcTarget := hdc;
if IsRectEmpty(PageRect) then
begin
rc.right := PageWidth * 1440 div LogX;
rc.bottom := PageHeight * 1440 div LogY;
end
else begin
rc.left := PageRect.Left * 1440 div LogX;
rc.top := PageRect.Top * 1440 div LogY;
rc.right := PageRect.Right * 1440 div LogX;
rc.bottom := PageRect.Bottom * 1440 div LogY;
end;
rcPage := rc;
Title := Caption;
// Оригинальная позиция BeginDoc
{ BeginDoc; }
LastChar := 0;
MaxLen := GetTextLen;
chrg.cpMax := -1;
repeat
chrg.cpMin := LastChar;
LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
until (LastChar >= MaxLen) or (LastChar = -1);
EndDoc;
end;
SendMessage(Handle, EM_FORMATRANGE, 0, 0);
end;

Nomadic советует:

Проблема, насколько помнится, касается только Delphi 2.0 без патчей.

сходил на http://www.borland.com и -

unit PrtRichU;
interface

uses SysUtils, Windows, Classes, ComCtrls, RichEdit, Printers;

procedure PrintRichEdit(const Caption: string; const RichEdt: TRichEdit);

implementation

procedure PrintRichEdit(const Caption: string; const RichEdt: TRichEdit);
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY, OldMap: Integer;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Printer, Range do
begin
BeginDoc;
hdc := Handle;
hdcTarget := hdc;
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
if IsRectEmpty(RichEdt.PageRect) then
begin
rc.right := PageWidth * 1440 div LogX;
rc.bottom := PageHeight * 1440 div LogY;
end
else
begin
rc.left := RichEdt.PageRect.Left * 1440 div LogX;
rc.top := RichEdt.PageRect.Top * 1440 div LogY;
rc.right := RichEdt.PageRect.Right * 1440 div LogX;
rc.bottom := RichEdt.PageRect.Bottom * 1440 div LogY;
end;
rcPage := rc;
Title := Caption;
LastChar := 0;
MaxLen := RichEdt.GetTextLen;
chrg.cpMax := -1; OldMap := SetMapMode(hdc, MM_TEXT);
SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);
try
repeat
chrg.cpMin := LastChar;
LastChar := SendMessage(RichEdt.Handle, EM_FORMATRANGE, 1,
Longint(@Range));
if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
until (LastChar >= MaxLen) or (LastChar = -1);
EndDoc;
finally
SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);
SetMapMode(hdc, OldMap);
end;
end;
end;

end.

и печатает.

Версия DBaware - TrxDBRichEdit из комплекта RX Library. Более корректный компонент - TrxRichEdit из комплекта RX Library. [000233]


Delphi 2

Проблема печати RTF

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

Я нашел одно решение, конечно не идеальное, но оно без проблем работает под Win95 - вызов редактора WordPad с недокументированным параметром:

shellExecute(mainForm.handle,
nil,
'write.exe',
'myfile.rtf /p',
nil,
SW_HIDE);

(Я выяснил, что вызов WRITE.EXE намного универсальнее, поскольку путь к файлу WORDPAD.EXE не всегда определен.)

Параметр "/p" является недокументированным. Код сначала запустит WordPad, напечатает файл, и затем закроет WordPad. SW_HIDE, является единственным параметром, позволяющим хоть как-то прятать работу WordPad.

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

[000234]


Исправление загрузки RTF текста через поток

Пришло мне письмо от читателя Лагонского Сергея Николаевича. Вот что он пишет:

В версии Borland Delphi 3 Client/Server я обнаружил, что при загрузке текста формата RTF методом "LoadFromStream" в компонент TRichEdit он не интерпретируется как RTF, а отображается полностью (со всеми управляющими символами). Разбираясь в исходном тексте модуля COMCTRLS.PAS (дата создания: 4 августа 1997 года, размер: 391728 байт) я нашел причину, из-за которой вышеуказанный метод не работал как надо. Ниже я привожу исходный и исправленный тексты реализации метода "TRichEditStrings.LoadFromStream" (измененные строки отмечены символом "!"):

1. Исходный текст

procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then
Converter := FConverter else
Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then TextType := SF_TEXT
else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position := Position;
!     if PlainText then TextType := SF_RTF
!     else TextType := SF_TEXT;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then Converter.Free;
end;
end;

2. Текст с исправлением:

procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then
Converter := FConverter else
Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then TextType := SF_TEXT
else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position := Position;
!     if PlainText then TextType := SF_TEXT
!     else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then Converter.Free;
end;
end;

С наилучшими пожеланиями

Сергей Лагонский.
[000388]


Delphi 2

Предел на размер текста в RichEdit

Я разместил на форме компонент TRichEdit, присвоил ему большой (104Кб) текст, но все попытки его редактирования свелись только в сторону уменьшения размера текста. Это проблема распределения памяти? Есть решение этой проблемы?

Я думаю что ответ на этот вопрос нужно искать в WIN95 API:

SendMessage(MyRichEdit.Handle, EM_EXLIMITTEXT, 0, NewBigSize);

- Richard Shotbolt [000932]


Синхронизация двух компонентов 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;
[000045]


Delphi 1

Двойной щелчок на TSpeedButton

Событие OnDblClick компонента TSpeedButton происходит только тогда, когда кнопка является частью группы (одна и более кнопок имеют GroupIndex > 0). [000558]


Конструирование Splitter

У меня есть форма с расположенными на ней компонентами TreeView и Memo. Значение свойства align обоих компонентов позволяет им занимать всю форму. Я хотел бы расположить между ними движок типа Splitter, пропорционально меняющий их размеры (один шире, другой меньше и наоборот), но к сожалению я обладаю лишь дистрибутивом Delphi2 (Splitter вошел в палитру только в Delphi3). Какой компонент мог бы с'имитировать поведение Splitter и как это реализовать?

Предположим, Ваш TreeView расположен в левой, а Memo в правой части формы. Вам нужно сделать следующее:

  • Установите свойство Align компонента TreeView на alLeft.
  • Вырежьте (Ctrl-X) компонент TMemo из вашей формы.
  • Добавьте компонент Panel и присвойте его свойству Align значение alClient.
  • Внутри панели разместите другой компонент Panel.
  • Установите его ширину, равной 8 пикселам, свойству Align присвойте значение alLeft.
  • Скопируйте вырезанный компонент TMemo в панель Panel1 и присвойте свойству Align значение alClient.
Panel2 - движок: теперь вам необходимо добавить процедуры, приведенные ниже. Ваш код будет выглядеть приблизительно так:

type
TForm1 = class(TForm)
TreeView1: TTreeview;
Panel1: TPanel;
Panel2: TPanel;
Memo1: TMemo;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift:TShiftState;
X, Y: Integer);
private
Resizing: Boolean;
public
...
end;

procedure TForm1.Panel2MouseDown(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Resizing:=true;
end;

procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Resizing:=false;
end;

procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if Resizing then begin
TreeView1.Width:=TreeView1.Width+X;
// Предохранение от странных ошибок перерисовки при изменении размеров:
Panel1.Invalidate;
end;
end;

Код может быть модифицирован для получения горизонтального движка - идея, надеюсь, понятна... [000046]


Обработчик события OwnerDraw в компоненте StatusBar

Обработчик должен выглядеть примерно так:

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
with statusbar1.Canvas do begin
Brush.Color := clRed;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));
end;
end;
[000047]


Показ всплывающих подсказок в строке состояния I

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

Шаг 1:

Расположите TStatusBar на всех формах, где вы хотите увидеть подсказки в строке состояния. Установите свойство SimplePanel в True и присвойте компоненту другое имя (я использую SBStatus). Смотри мой комментарий относительно имени, который я поместил в шаге 4.

Шаг 2:

Создайте необходимые подсказки в свойствах Hint. Не забудьте вставить '|', если вам необходим длинный текст.

Шаг 3:

Поместите следующую строку в обработчике события FormCreate вашей формы:

Application.OnHint := DisplayHint;

Шаг 4:

Создайте эту процедуру. Пожалуйста обратите внимание на комментарии.

procedure TFrmMain.DisplayHint(Sender: TObject);
var
Counter, NumComps: integer;
begin
with Screen.ActiveForm do
begin
NumComps := ControlCount - 1;
for Counter := 0 to NumComps do
{SBStatus - имя всех моих компонентов TStatusBar. При необходимости его можно изменить.}
if (TControl(Controls[Counter]).Name = 'SBStatus') then
begin
if (Application.Hint = '') then
{ConWorkingName - используемая константа. При необходимости ее можно изменить.}
TStatusBar(Controls[Counter]).SimpleText := ConWorkingName
else
TStatusBar(Controls[Counter]).SimpleText := Application.Hint;
break;
end;
end;
end; {DisplayHint}

Не забудьте поместить 'Procedure DisplayHint(Sender: TObject) в секции Public.

Это все, что вы должны сделать. Если вы хотите придать такую функциональность другим формам, просто поместите на них TStatusBar и установите свойство Hint у необходимых компонентов. Я надеюсь это просто. [000306]


Показ всплывающих подсказок в строке состояния II

Пришло мне письмо:

...cовет за номером 000306 содержит интересную идею -- выводить Hint'ы не на основную форму, а на активную, я сам до этого не дошел... Но не совсем понятно, чем автору не понравился стандартный метод TForm.FindComponent, существующий со времен Delphi I ? С его использованием метод ShowHint выглядит попроще, да и работает не хуже:

procedure TAnyForm.ShowHint;
var
C: TStatusBar;
begin
// ищем наш StatusBar1 на активной форме
C := TStatusBar(Screen.ActiveForm.FindComponent('StatusBar1'));
// если не найден -- ищем на основной форме
if not Assigned(C)
then C := TStatusBar(Application.MainForm.FindComponent('StatusBar1'));
// если что-то обнаружено -- рисуем на нём наш текст
if Assigned(C)
then C.SimpleText := '  ' + Application.Hint;
end;

Желаю Вам всяческих успехов!

С уважением, Иваненко Фёдор Григорьевич.

e-mail: theodor_iv@mail.ru [000498]


Установка атрибутов -=Только для чтения=- у столбцов компонента StringGrid

Манипулирование вышеуказанным атрибутом возможно в обработчике события OnSelectCell:

if Col mod 2 = 0 then
grd.Options := grd.Options + [goEditing]
else
grd.Options := grd.Options - [goEditing];
[000048]


Помещение изображения в ячейку StringGrid
Возможно ли поместить изображение в одну из ячеек компонента StringGrid?

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

with StringGrid1.Canvas do
begin
{...}
Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);
{...}
end;

Достичь цели позволяют методы Draw() и StretchDraw() объекта TCanvas. В приведенном примере переменная Image1 класса TImage содержит заранее загруженное изображение. [000049]


Сохранение и чтение Tstringgrid

Как мне сохранить целый Stringgrid со всеми ячейками в файле?

Procedure

SaveGrid;
var f:textfile;
x,y:integer;
begin
assignfile (f,'Filename');
rewrite (f);
writeln (f,stringgrid.colcount);
writeln (f,stringgrid.rowcount);
For X:=0 to stringgrid.colcount-1 do
For y:=0 to stringgrid.rowcount-1 do
writeln (F, stringgrid.cells[x,y]);
closefile (f);
end;

Procedure LoadGrid;
var f:textfile;
temp,x,y:integer;
tempstr:string;
begin
assignfile (f,'Filename');
reset (f);
readln (f,temp);
stringgrid.colcount:=temp;
readln (f,temp);
stringgrid.rowcount:=temp;
For X:=0 to stringgrid.colcount-1 do
For y:=0 to stringgrid.rowcount-1 do begin
readln (F, tempstr);
stringgrid.cells[x,y]:=tempstr;
end;
closefile (f);
end;
[000050]


Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid

Я наконец нашел время и создал заказной компонент TWrapGrid, функционально идентичный TStringGrid, но умеющий переносить текст в ячейках. Пока это бета-версия, поэтому поэкспериментируйте с ним, и в случае наличия каких-либо замечаний или предложений не забудьте уведомить об этом меня. При использовании компонента не забывайте про RowHeights (или DefaultRowHeight), т.к. при переносе текста потребуется отобразить несколько строк.

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

Присылайте свой комментарии и пожелания. Вот код:

{  Код заказного компонента для Delphi.
Позволяет переносить текст в TStringGrid, отсюда и его имя - TWrapGrid.
Автор Luis J. de la Rosa.
E-mail: delarosa@ix.netcom.com
Вы свободны в использовании, распространении и улучшении кода.

Для использования:  Выберите в Delphi пункты меню 'Options' - 'Install Components'.
Нажмите 'Add'.
Найдите и выберите файл с именем 'Wrapgrid.PAS'.
Нажмите 'OK'.
После этого вы увидете компонент во вкладке "Samples" палитры компонентов
Delphi.
После этого вы можете использовать компонент вместо стандартного TStringGrid.

Пожалуйста шлите любые комментарии и пожелания на адрес delarosa@ix.netcom.com.
Успехов!

Несколько дополнительных замечаний по коду:
Методы Create и DrawCell были перекрыты. Everything else should
behave just like a TStringGrid.
The Create sets the DefaultDrawing to False, so you don't need to.

Also, I am using the pure block emulation style of programming, making my
code easier to read.
}
unit Wrapgrid;

interface

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

type
TWrapGrid = class(TStringGrid)
private
{ Private declarations }
protected
{ Protected declarations }
{ Процедура DrawCell осуществляет перенос текста в ячейке }
procedure DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState); override;
public
{ Public declarations }
{ Процедура Create перекрывается для того, чтобы использовать процедуру DrawCell
по умолчанию }
constructor Create(AOwner : TComponent); override;
published
{ Published declarations }
end;

procedure Register;

implementation

constructor TWrapGrid.Create(AOwner : TComponent);
begin
{ Создаем TStringGrid }
inherited Create(AOwner);

{ Заставляем компонент перерисовываться нашей процедурой по умолчанию DrawCell }
DefaultDrawing := FALSE;
end;

{ Процедура DrawCell осуществляет перенос текста в ячейке }
procedure TWrapGrid.DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState);
var
Sentence,                  { Выводимый текст }
CurWord : String;          { Текущее выводимое слово }
SpacePos,                  { Позиция первого пробела }
CurX,                      { Х-координата 'курсора' }
CurY : Integer;            { Y-координата 'курсора' }
EndOfSentence : Boolean;   { Величина, указывающая на заполненность ячейки }
begin
{ Инициализируем шрифт, чтобы он был управляющим шрифтом }
Canvas.Font := Font;

with Canvas do begin
{ Если это фиксированная ячейка, тогда используем фиксированный цвет }
if gdFixed in AState then begin
Pen.Color := FixedColor;
Brush.Color := FixedColor;
end
{ в противном случае используем нормальный цвет }
else begin
Pen.Color   := Color;
Brush.Color := Color;
end;

{ Рисуем подложку цветом ячейки }
Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;

{ Начинаем рисование с верхнего левого угла ячейки }
CurX := ARect.Left;
CurY := ARect.Top;

{ Здесь мы получаем содержание ячейки }
Sentence := Cells[ACol, ARow];

{ для каждого слова ячейки }
EndOfSentence := FALSE;
while (not EndOfSentence) do begin
{ для получения следующего слова ищем пробел }
SpacePos := Pos(' ', Sentence);
if SpacePos > 0 then begin
{ получаем текущее слово плюс пробел }
CurWord := Copy(Sentence, 0, SpacePos);

{ получаем остальную часть предложения }
Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
end
else begin
{ это - последнее слово в предложении }
EndOfSentence := TRUE;
CurWord := Sentence;
end;

with Canvas do begin
{ если текст выходит за границы ячейки }
if (TextWidth(CurWord) + CurX) > ARect.Right then begin
{ переносим на следующую строку }
CurY := CurY + TextHeight(CurWord);
CurX := ARect.Left;
end;

{ выводим слово }
TextOut(CurX, CurY, CurWord);
{ увеличиваем X-координату курсора }
CurX := CurX + TextWidth(CurWord);
end;
end;
end;

procedure Register;
begin
{ Вы можете изменить закладку Samples на любую другую
палитре компонентов Delphi }
RegisterComponents('Samples', [TWrapGrid]);
end;

end.
[000314]


TStringGrid и файловый поток

Какое наилучшее решение для сохранения экземпляра TStringGrid (150x10)?

Если вы хотите сохранить это на диске:

var:
myStream: TFileStream;
begin
myStream1 := TFileStream.Create('grid1.sav', fmCreate);
myStream1.WriteComponent(StringGrid1);
myStream1.Destroy;
end;

Для обратного чтения:

myStream    := TFileStream.Create('grid1.sav', fmOpenRead);
StringGrid1 := myStream1.ReadComponent(StringGrid1) as TStringGrid;

[000468]


Delphi 1

Выравнивание колонок StringGrid I

Организуйте обработчик события сетки OnDrawCell. Создайте код обработчика подобный этому:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
var
Txt: array [0..255] of Char;
begin
StrPCopy(Txt, StringGrid1.Cells[Col, Row]);
SetTextAlign(StringGrid1.Canvas.Handle,
GetTextAlign(StringGrid1.Canvas.Handle)
and not(TA_LEFT OR TA_CENTER) or TA_RIGHT);
ExtTextOut(StringGrid1.Canvas.Handle, Rect.Right - 2, Rect.Top + 2,
ETO_CLIPPED or ETO_OPAQUE, @Rect, Txt, StrLen(Txt), nil);
end;

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

Успехов.

Kurt [000647]


Delphi 1

Выравнивание колонок StringGrid II

Нижеприведенный код выравняет данные компонента по правому краю:

procedure TForm1.StringGrid1DrawCell (Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var lRow, lCol : Longint;
begin
lRow := Row;
lCol := Col;
with Sender as TStringGrid, Canvas do begin
if (gdSelected in State) then begin
Brush.Color := clHighlight;
end
else if (gdFixed in State) then begin
Brush.Color := FixedColor;
end
else begin
Brush.Color := Color;
end;
FillRect(Rect);
SetBkMode(Handle, TRANSPARENT);
SetTextAlign(Handle, TA_RIGHT);
TextOut(Rect.Right-2, Rect.Top+2, Cells[lCol, lRow]);
end;
end;

Хитрость заключается в установке выравнивания текста TA_RIGHT, позволяющей осуществлять вывод текста, начиная с правой стороны (от правой границы). Не бойтесь, текст не будет напечатан задом наперед!

Вы наверное уже обратили внимание на объявление локальных переменных lCol и lRow. На входе я присваиваю им значения параметров Col и Row (имя, которое дало мне Delphi IDE). Дело в том, что объект TStringGrid имеет свойства с именами Col и Row. Эти свойства будут доступны в теле блока "with Sender as TStringGrid", но они не являются параметрами для всех обявленных в шапке блока объектов ((речь идет об объекте Canvas, у которого нет свойств с именами Col и Row - В.О.)). [000678]


Delphi 1

Фокус ячейки TStringGrid

procedure SetGridFocus(SGrid: TStringGrid; r, c:integer);
var
SRect: TGridRect;
begin
with SGrid do
begin
SetFocus;   {Передаем фокус сетке}
Row := r;   {Устанавливаем Row/Col}
Col := c;
SRect.Top := r;   {Определяем выбранную область}
SRect.Left := c;
SRect.Bottom := r;
SRect.Right := c;
Selection := SRect; {Устанавливаем выбор}
end;

end;

Для вызова процедуры:

SetGridFocus(StringGrid1, 10, 2);

Это всегда срабатывает в случае, если никакая ячейка не выбрана или фокус имеет другой элемент управления.

Надеюсь что помог вам.

Simon [000657]


Delphi 1

TStringgrid с фокусом (OnDrawCell)

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

procedure TForm1.DrawCell (Sender : TObject;
Col    : Longint;
Row    : Longint;
Rect   : TRect;
State  : TGridDrawState);
var
lRow, lCol : LongInt;
S : string;
begin
lRow := Row;
lCol := Col;
with Sender as TStringGrid, Canvas  do begin
if (gdSelected in State)  then begin
Brush.Color := clHighlight;  { *** }
end
else if (lRow < FixedRows) or (lCol < FixedCols) then begin
Brush.Color := FixedColor;
end
else begin
Brush.Color := Color;
end;
FillRect(Rect);
SetBkMode(Handle, TRANSPARENT);
TextOut(Rect.Left+2, Rect.Top+2, Cells[lCol, lRow]);
end;
end;

Строка с комментарием { *** } в данном контексте ключевая. Она "сообщает" о том, что если мы рисуем ячейку, которая имеет фокус, то мы ее рисуем с применением цвета подсветки (highlight) (хотя вы бы могли здесь использовать любой другой нравящийся вам цвет), хотя никто нам специально о необходимости подкрашивания области сфокусированной ячейки и не говорил. Единственная проблема возникает со шрифтом, но в конечном счете я обнаружил, что она решается сама собой, если установить свойство компонента TStringGrid DefaultDrawing в TRUE (я потерял немало времени, решая проблему цвета шрифта со значением FALSE!). Попробуйте также поиграться с другими настройками цветов, может вам повезет и вы добъетесь неописуемой красоты компонента TStringGrid. [000659]


Delphi 1

Помещение компонентов в StringGrid

Некоторое время тому назад такой вопрос уже ставился: возможно ли поместить элемент управления, например, CheckBox или ComboBox внутрь компонента ...Grid. Я сегодня помозговал и нашел неплохую, на мой взгляд, технологию. Это работает! Вот решение для тех, кто этим интересуется:

  1. При создании компонента (в обработчике OnCreate), создайте его объекты Objects[C,R], например TCheckBox.Create(Self). Имейте в виду, что вы должны присвоить ячейкам Cells[C,R] какие-либо значения прежде, чем чем вы сможете иметь доступ к Objects[C,R]. Установите у вновь созданного компонента свойство Visible в FALSE, а свойство parent в SELF. Осуществите другую необходимую инициализацию. Имейте в виду, что вы должны внести необходимые модули в список uses, если создаете тип компонента, которого нигде кроме как на форме нет.

  2. Создайте процедуру, берущую координаты колонки/строки и правильно позиционирующую соотвествующий объект в пределах прямоугольника ячейки, например:

    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 расчитывается относительно верхнего левого угла строки сетки, и родителем компонента является форма).

  3. В обработчике события сетки OnSelectCell проверьте, располагается ли элемент Objects в текущей колонке Col и строке Row TControl - если так, установите его свойство visible в FALSE. Теперь вызовите процедуру установления координат из шага 2 для *НОВЫХ* Col и Row, передавая их из параметров обработчика события в параметры функции.

  4. В обработчике OnTopLeftChanged просто вызовите FixObjPosn

  5. В обработчике события OnDrawCell во-первых, если ячейка выбрана, EXIT. Если элемент ячейки Objects не TControl, также EXIT. В противном случае вам нужно создать код, обеспечивающий отрисовку "фасада" каждого типа элемента управления, которого вы разместили в сетке.

  6. Обратите внимание на то, что если вы делаете что-либо с элементом управления, на который влияют ДРУГИЕ элементы управления (например, изменение статуса какой-либо радиокнопки из группы, или операции enable/disable), вы должны вызвать метод сетки Refresh.
Опс! Это звучит немного запутанно, но это работает. Успехов!

- Neil Rubenking [000718]


Одной строкой

Выбор строки/колонки компонента TStringGrid

Вот функция, выбирающая при нажатии на кнопку первую строку сетки. Это работает независимо от размера сетки и количества фиксированных строк/колонок.

procedure TForm1.Button1Click(Sender: TObject);
VAR NewSel: TGridRect;
begin
WITH StringGrid1 DO
BEGIN
NewSel.Left := FixedCols;
NewSel.Top := FixedRows;
NewSel.Right := ColCount-1;
NewSel.Bottom := FixedRows;
Selection := NewSel;
END;
end;

- Neil J. Rubenking

SottNick добавляет:

Да. Догадаться сложновато, но:

 StringGrid1.Row := номер строки от нуля;
 StringGrid1.Col := номер столбца от нуля;
[000818]


Delphi 1

Ширина колонок TStringGrid

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

Попробуйте это:

procedure TForm1.StringGrid1SelectCell(Sender: TObject; vCol, vRow: Longint;
var CanSelect: Boolean);
VAR Wid: Integer;
begin
WITH Sender AS TStringGrid DO
BEGIN
Wid := Canvas.TextWidth(Cells[Col,Row]+' ');
IF Wid > ColWidths[Col] THEN
ColWidths[Col] := Wid;
END;
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
VAR Wid : Integer;
begin
IF Key = #13 THEN
WITH Sender AS TStringGrid DO
BEGIN
Wid := Canvas.TextWidth(Cells[Col,Row]+' ');
IF Wid > ColWidths[Col] THEN
ColWidths[Col] := Wid;
END;
end;

Имейте в виду, что в обработчике события OnSelectCell я переименовал параметры Col и Row на vCol и vRow, чтобы избежать путаницы со свойствами StringGrid, имеющими те же имена. StringGrid c данными методами всегда расширяет данную колонку, если вновь добавляемая строка имеет ширину большую чем текущая ширина колонки.

- Neil J. Rubenking [000821]


Delphi 1

Цвет неактивной ячейки StringGrid

...если я щелкаю на любой ячейке StringGrid2, последняя выбранная ячейка в StringGrid1 становится синей...

Создайте обработчик (если он отсутствует) события сетки OnDrawCell и включите в него следующий код:

procedure TForm1.StringGrid3DrawCell(Sender: TObject; vCol, vRow: Longint; Rect: TRect;   State: TGridDrawState);
begin
IF Sender = ActiveControl THEN Exit;
IF NOT (gdSelected IN State) THEN Exit;
WITH Sender AS TStringGrid DO
BEGIN
Canvas.Brush.Color := Color;
Canvas.Font.Color  := Font.Color;
Canvas.TextRect(Rect, Rect.Left+2, Rect.Top+2,
Cells[vCol, vRow]);
END;
end;

Имейте в виду, что в обработчике события OnDrawCell я переименовал параметры Col и Row на vCol и vRow, чтобы избежать путаницы со свойствами StringGrid, имеющими те же имена. Данный метод выполняется немедленно после того, как сетка становится неактивной, и после того как запрошенная ячейка становится НЕвыбранной. В любом из этих случаев вы должны нарисовать невыбранную ячейку для НЕАКТИВНОЙ сетки - т.е. в тех случаях, когда у вас получается "неправильный" цвет. Вы просто берете работу Delphi по закрашиванию ячеек на себя, пропуская defaultDrawing (отрисовку по умолчанию), для таких ячеек, но в то же время разрешая Delphi поработать за вас во всех остальных случаях.

- Neil J. Rubenking [000833]


Вставка и удаление строк в StringGrid

...я не нашел никаких методов для вставки и удаления строк...

Поскольку свойство Cols[x] компонента TStringGrid реально является компонентом TStrings, все методы TStrings применимы также и к Cols[x].

Недавно в интернете я нашел реализацию расширенных функций TStringGrid:

    Создано:           Dennis Passmore
                       1929 Mango Tree Drive
                       Edgewater, Fl. 32141
                       CIS: 71640,2464
                       Март 1, 1996
Данный код свободен в использовании при одном условии: в исходном коде должна присутствовать указанная выше кредитка со ссылкой на автора.

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

*)

unit GridFunc;

interface

uses
Sysutils, WinProcs, Grids;

procedure InsertRow   (Sender: TStringGrid; ToIndex: Longint);
procedure DeleteRow   (Sender: TStringGrid; FromIndex: Longint);
procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);

implementation

type
TCSGrid = class(TStringGrid)
private
public
procedure MoveRow   (FromIndex, ToIndex: Longint);
procedure MoveColumn(FromIndex, ToIndex: Longint);
end;

procedure TCSGrid.MoveRow(FromIndex,ToIndex: Longint);
begin
RowMoved(FromIndex, ToIndex); { Защищенный метод TStringGrid }
end;

procedure TCSGrid.MoveColumn(FromIndex, ToIndex: Longint);
begin
ColumnMoved(FromIndex, ToIndex);{ Защищенный метод TStringGrid }
end;

procedure InsertRow(Sender: TStringGrid; ToIndex: Longint);
var
xx,yy: Integer;
begin
if ToIndex>=0 then
with TCSGrid(Sender) do
if (ToIndex<=RowCount) then
begin
RowCount := RowCount + 1;
xx := RowCount - 1;
for yy := 0 to ColCount - 1 do
begin
Cells[yy,xx] := ' ';
ObJects[yy,xx] := nil;
end;
if ToIndex<RowCount-1 then
MoveRow(RowCount-1,ToIndex);
end
else
MessageBeep(0)
else
MessageBeep(0);
end;

procedure DeleteRow(Sender: TStringGrid; FromIndex: Longint);
begin
if FromIndex>l;=0 then
with TCSGrid(Sender) do
if (RowCount>0)and(FromIndex<RowCount) then
begin
if (FromIndex<RowCount-1) then
MoveRow(FromIndex,RowCount-1);
Rows[RowCount-1].Clear;
RowCount := RowCount-1;
end
else
MessageBeep(0)
else
MessageBeep(0);
end;

procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
var
xx,yy: Integer;
begin
if ToIndex>=0 then
with TCSGrid(Sender) do
if (ToIndex<=ColCount) then
begin
ColCount := ColCount + 1;
xx := ColCount - 1;
Cols[xx].BeginUpdate;
for yy := 0 to RowCount - 1 do
begin
Cells[xx,yy] := ' ';
ObJects[xx,yy] := nil;
end;
Cols[xx].EndUpdate;
if ToIndex<ColCount-1 then
MoveColumn(ColCount-1,ToIndex);
end
else
MessageBeep(0)
else
MessageBeep(0);
end;

procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);
begin
if FromIndex>=0 then
with TCSGrid(Sender) do
if (ColCount>0)and(FromIndex<ColCount) then
begin
if (FromIndex<ColCount-1) then
MoveColumn(FromIndex,ColCount-1);
Cols[ColCount-1].Clear;
ColCount := ColCount-1;
end
else
MessageBeep(0)
else
MessageBeep(0);
end;

end.

- Dennis Passmore [000848]


Добавление элементов управления в TTabbedNotebook и TNotebook

Я несколько раз видел в конференциях вопросы типа "как мне добавить элементы управления в TTabbedNotebook или TNotebook во время выполнения программы?". Теперь, когда у меня выдалось несколько свободных минут, я попытаюсь осветить этот вопрос как можно подробнее:

TTabbedNotebook

Добавление элементов управления в TTabbedNotebook во время проектирования - красивая и простая задача. Все, что Вам нужно - это установить свойство PageIndex или ActivePage на необходимую страницу и начать заполнять ее элементами управления.

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

Первым шагом к раскрытию тайны послужит просмотр файла \DELPHI\DOC\TABNOTBK.INT, интерфейсной секции модуля TABNOTBK.PAS, в котором определен класс TTabbedNotebook. Беглый просмотр позволяет обнаружить класс TTabPage, описанный как хранилище элементов управления отдельной страницы TTabbedNotebook.

Вторым шагом в исследовании TTabbedNotebook может стать факт наличия свойством Pages типа TStrings. В связи с этим отметим, что Delphi-классы TStrings и TStringList соорганизуются с двумя свойствами: Strings и Objects. Другими словами, для каждой строки в TStrings есть указатель на соответствующий Objects. Во многих случаях этот дополнительный указатель игнорируется, нам же он очень пригодится.

После небольшого эксперимента выясняем, что свойство Objects указывает на нашу копию TTabPage и ссылается на имя страницы в свойстве Strings. Блестяще! Всегда полезно знать что ищешь. Теперь посмотрим что мы можем сделать:

{ Данная процедура добавляет кнопку в случайной позиции на }
{ текущей странице данного TTabbedNotebook.                }

procedure AddButton(tabNotebook : TTabbedNotebook);
var
tabpage : TTabPage;
button : TButton;
begin
with tabNotebook do
tabpage := TTabPage(Pages.Objects[PageIndex]);
button := TButton.Create(tabpage);
try
with button do begin
Parent := tabpage;
Left   := Random(tabpage.ClientWidth - Width);
Top    := Random(tabpage.ClientHeight - Height);
end;
except
button.Free;
end;
end;

TNotebook

Операция по заполнению элементами управления компонента TNotebook почти такая же, как и в TTabbedNotebook - разница лишь в типе класса - TPage вместо TTabPage. Тем не менее, если вы заглянете в DELPHI\DOC\EXTCTRLS.INT, декларацию класса TPage вы там не найдете. По неизвестной причине Borland не включил определение TPage и в DOC-файлы, поставляемые с Delphi. Декларация TPage в EXTCTRLS.PAS (можно найти в библиотеке VCL-исходников), правда, расположена в интерфейсной части модуля. Мы восполним пропущенную информацию о классе TPage:

TPage = class(TCustomControl)
private
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
protected
procedure ReadState(Reader: TReader); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property Height stored False;
property TabOrder stored False;
property Visible stored False;
property Width stored False;
end;

Теперь, по аналогии с вышеприведенной процедурой, попробуем добавить кнопку на TNotebook. Все, что мы должны сделать - заменить "TTabbedNotebook" на "TNotebook" и "TTabPage" на "TPage". Вот что должно получиться:

{ Данная процедура добавляет кнопку в случайной позиции на }
{ текущей странице данного TNotebook.                      }

procedure AddButton(Notebook1 : TNotebook);
var
page    : TPage;
button  : TButton;
begin
with Notebook1 do
page := TPage(Pages.Objects[PageIndex]);
button := TButton.Create(page);
try
with button do begin
Parent := page;
Left   := Random(page.ClientWidth - Width);
Top    := Random(page.ClientHeight - Height);
end;
except
button.Free;
end;
end;

Остальное не менее просто! [000051]


Недоступная закладка в компоненте 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}
[000052]


Одной строкой

Исходный код Tabbednotebook

Имейте в виду, что исходный код TABS.DCU и TABNOTBK.DCU (компоненты TTabSet и TTabbedNotebook) может быть недоступен в вашей версии поставки Delphi. [000328]


Delphi 1

Динамические создание объектов в Tabbednotebook I

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;

[000426]


Delphi 1

Динамические создание объектов в Tabbednotebook II

Как мне поместить кнопку (во время выполнения программы) на страницу TabbedNoteBook?

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;

[000687]


Создание компонента TTable без формы I

Решение 1

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

FSession := TSession.Create(nil);
FDatabase := TDatabase.Create(nil);
FSession.SessionName := 'DBSession'
FDatabase.Connected := False;
FDatabase.AliasName := Database;
FDatabase.DatabaseName := USER_DATABASE;
FDatabase.SessionName  := FSession.SessionName;

FUserTBL := TTable.Create(nil);
FUserTBL.DatabaseName := FDatabase.DatabaseName;
FUserTBL.SessionName := FSession.SessionName;
FUserTBL.TableName := USERTBL;
FUserTBL.IndexName := USERSpIndex;

FUserSource := TDataSource.Create(nil);
FUserSource.DataSet := FUserTBL;

Решение 2

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

unit Unit2;

interface
uses db, DBTables, dialogs;

type fake = class(Ttable)
procedure fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);
end;

var
MyTable : fake;

implementation

procedure fake.fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);
begin
showmessage('Здравствуй, Вася');
end;

Initialization
MyTable := fake.create(nil);
With Mytable do begin
DataBaseName := 'dbdemos';
TableName := 'biolife';
OnFilterRecord := MyTable.fakeFilterRecord;
Filtered := true;
active := true;
end;

{проверка получением неких данных...}
showmessage(MyTable.fields[1].asstring);

Finalization
{Важно!  MyTable не имеет родителя, - уничтожаем объект сами, иначе память не высвобождается...}
MyTable.free;

end.
[000053]


Создание компонента TTable без формы II

Вы можете использовать TTable, не размещая компонент на форме:

procedure TForm1.TotalPopulation:double;
var
Tbl:TTable;
begin
Result := 0;
Tbl := TTable.Create(nil);
try
tbl.DatabaseName := 'DBDEMOS';
tbl.TableName := 'COUNTRY';
Tbl.Open;
tbl.First;
while not Tbl.EOF do begin
Result := Result+Tbl.FieldByName('Population').AsFloat;
Tbl.Next;
end;
Tbl.Close;
finally
Tbl.Free;
end;
end;

[000359]


Создание компонента TTable без формы III

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

with Table1 do begin
Close;
TableName := 'test.db';
TableType := ttParadox;
DatabaseName := 'Sample';
FieldDefs.Clear;
FieldDefs.Add('Field1',ftString,10,false); {FldName,FldType,FldLength,Required}
...
IndexDefs.Add('','Field1',[ixPrimary]);  { Создание первичного индекса }
CreateTable;
end;

[000375]


Одной строкой

Замена KeyFind

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

try
Table1.Insert;
except
on EDBEngineError do
{ все что здесь - дубликат };
end;

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

- David Martin
UDFMARTIN @ cc.memphis.edu [000365]


Синхронизация таблицы и StringList

Допустим что вы имеете TTable с именем Table1 и DBGrid с именем DBGrid1:

  1. В секции модуля interface объявите переменную:

    FieldLst: TStringList ;

  2. Установите свойство формы KeyPreview в TRUE
  3. В обработчике события формы OnCreate добавьте:

    FieldLst := TStringList.Create ;

  4. В обработчике события формы OnDestroy добавьте:

    FieldLst.Free ;

  5. В обработчике события формы OnKeyUp добавьте:

    if (ssCtrl in Shift) and (Key in [Ord('D'), Ord('d')]) then
    if (FieldLst.Count > 0 ) then
    begin
    {Если вам необходимы все предыдущие данные полей}
    {for nFld := 0 to Table1.FieldCount - 1 do
    Table1.Fields[nFld].AsString := FieldLst.Strings[nFld] ;}

    {Если вы хотите только поле, с которым сейчас имеете дело }
    DBGrid1.Fields[DBGrid1.SelectedIndex].AsString := FieldLst.Strings[DBGrid1.SelectedIndex] ;
    end ;

  6. Обработчик события таблицы BeforeInsert должен выглядеть следующим образом:

    procedure TForm1.Table1BeforeInsert(DataSet: TDataset);
    var
    nFld: Integer ;
    bmPos: TBookMark ;
    begin
    if (not Table1.BOF) and (Assigned( FieldLst )) then
    try
    bmPos := Table1.GetBookMark ;
    Table1.DisableControls ;
    Table1.Prior ;
    FieldLst.Clear ;
    for nFld := 0 to Table1.FieldCount - 1 do
    FieldLst.Add( Table1.Fields[nFld].AsString ) ;
    Table1.GotoBookMark( bmPos ) ;
    Table1.FreeBookMark( bmPos ) ;
    Table1.EnableControls ;
    except
    on E: EOutOfMemory do ShowMessage( E.Message ) ;
    end ;
    end;

    Надеюсь, что это будет работать. {Обратите внимание, что при обработке события OnKeyUp вы можете воспользоваться закомментаренными строками, которые позволят вам с помощью комбинации клавиш Ctrl-D получить все предыдущие данные полей. Если вы уберете этот комментарий, то не забудьте прокомментировать строку с DBGrid1....}

    OAmiry/Borland [000366]


Функция Locate

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

function Locate( const oTable: TTable; const oField: TField; const sValue: String ): Boolean ;
var
bmPos: TBookMark ;
bFound: Boolean ;
begin
Locate := FALSE ;
bFound := FALSE ;
if not oTable.Active then Exit ;
if oTable.FieldDefs.IndexOf( oField.FieldName ) < 0 then Exit ;
bmPos := oTable.GetBookMark ;
with oTable do
begin
DisableControls ;
First ;
while not EOF do
if oField.AsString = sValue then
begin
Locate := TRUE ;
bFound := TRUE ;
Break ;
end

[000368]


Создание индекса во время выполнения программы

Ниже приведен код обработчика кнопки 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.

OAmiry/Borland [000370]


Одной строкой

Проверка изменения данных таблицы

В обработчике события формы OnClose вы можете поместить следующий код:

if Table1.State in dsEditModes then
if MessageDlg( 'Сохранить изменения?', mtInformation, [mbYes, mbNo], 0 ) = mrYes then
Table1.Post
else
Table1.Cancel ;

[000462]


Одной строкой

Очистка таблицы (с проверкой)

TTable имеет метод EmptyTable.

Пример:

try
with Table1 do
begin
Close ;
Exclusive := true ;
Open ;
EmptyTable ;
Close ;
end ;
except
on E: EDBEngineError do ShowMessage(E.Message) ;
end ;

[000464]


Delphi 1

Создание таблицы по образу и подобию

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

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;

...один способ сделать это. [000513]


Текущая TTable пуста?

Галимарзанов Фанис пишет:

Проверить таблицу - имеет она записи или нет, можно с помощью простой функции

Function NotEmptySet(inSet:TDataSet):boolean;
begin
Result:=Not (inSet.Bof and inSet.eof);
end;

Проще некуда, используются известные свойства DataSet.Bof и DataSet.Eof Удалить все записи из таблицы (вместо EmptyTable)

while NotEmptySet(dm.taAb) do dm.taAb.Delete;

[000555]


Delphi 1

Пример SetText/GetText строкового поля

Ниже приведен простой пример поля ID, содержащего A,B,C, для вывода (и обновления) *всех* элементов управления как 1,2,3:

procedure TForm1.Table1IDGetText(Sender: TField;
var Text: OpenString; DisplayText: Boolean);
var s: string;
begin
s := (Sender as TStringField).Value;
case s[1] of
'A' : Text := '1';
'B' : Text := '2';
'C' : Text := '3';
else Text := '9'
end;
end;

procedure TForm1.Table1IDSetText(Sender: TField; const Text: String);
var s: string;
begin
case Text[1] of
'1' : s := 'A';
'2' : s := 'B';
'3' : s := 'C';
else s := 'Z'
end;
(Sender as TStringField).Value := s;
end;

HTH

=== Mike Orriss === [000620]


Delphi 1

Использование DBIopenlocklist

Вот пример поиска пользователей данной таблицы. Имейте в виду, что свойство TStringList Duplicate установлено в dupIgnore, поскольку пользователь может иметь более одной блокировки таблицы. При работе с dBase возвращается только блокировка текущего сеанса, тогда как с Paradox функция покажет всех пользователей, получивших доступ к этому же NET-файлу.

procedure GetTableUserList(ATable: TTable; AStringList: TStringList);
var hUserCur: hDBICur;
pUserBuf: pByte;
begin
AStringList.Clear;
AStringList.Duplicates := dupIgnore;
Check(DBIOpenLockList(ATable.Handle,True,True,hUserCur));
GetMem(pUserBuf,SizeOf(LOCKDesc));
try
while (DBIGetNextRecord(hUserCur,dbiNOLOCK,pUserBuf,nil) = DBIERR_NONE) do
AStringList.Add(StrPas(pLOCKDesc(pUserBuf)^.szUserName))
finally
FreeMem(pUserBuf,SizeOf(LOCKDesc));
DBICloseCursor(hUserCur);
end;
end;

- Reinhard Kalinke [000874]


Delphi 1

Перемещение на страницу Tabset по имени

Разместите компоненты Tabset(TabSet1) и Edit (Edit1) на вашей форме. Измените свойство компонента Tabset Tabs для размещения в списке строк следующих четерых закладок:

  • Hello
  • World
  • Of
  • Delphi
Создайте обработчик события onChange компонента Edit1 как показано ниже:

procedure TForm1.Edit1Change(Sender: TObject);
var
I : Integer;
begin
for  I:= 0 to tabset1.tabs.count-1 do
if  edit1.text = tabset1.tabs[I] then
tabset1.tabindex:=I;
end;

Теперь при наборе любого из существующих имен в edit1 соотвутствующая закладка будет выведена на передний план. [000537]


Ускорение работы 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.
[000054]


Создание компонента во время работы приложения
Var
MyButton  :  TButton;

MyButton := TButton.Create(MyForm);   //  MyForm теперь "обладает" MyButton
with MyButton do
BEGIN
Parent := MyForm;    //  Выбираем родителей. MyForm "усыновляет" MyButton
height := 32;
width := 128;
caption := 'Я здесь!';
left := (MyForm.ClientWidth - width) div 2;
top := (MyForm.ClientHeight - height) div 2;
END;

Inprise также рассказывала об этом в выпусках TechInfo.

Поищите

ti2938.asc Creating Dynamic Components at Runtime

на публичном WWW или FTP сайте компании Inprise. [000057]


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

Мне необходимо найти индекс компонента в родительском списке дочерних элементов управления. Я попытался модифицировать prjexp.dll, но без успеха. У кого-нибудь есть идеи?

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

{ функция, возвращающая индекс искомого компонента в
списке родителя; возвращает -1 при отсутствии компонента }
function IndexInParent(vControl: TControl): integer;
var
ParentControl: TWinControl;
begin
{делаем "слепок" родителя через базовой класс на предмет доступности }
ParentControl := TForm(vControl.Parent);
if (ParentControl <> nil) then
begin
for Result := 0 to ParentControl.ControlCount - 1 do
begin
if (ParentControl.Controls[Result] = vControl) then Exit;
end;
end;
{ если мы уж попали в это место, то либо не найден компонент, либо компонент не имел родителя }
Result := -1;
end;
[000056]


Массив компонентов I
Возможно ли создание массива компонентов? Для показа статуса я использую набор LED-компонентов и хотел бы иметь к ним доступ, используя массив.

Прежде всего необходимо объявить массив:

LED : array[1..10] of TLed;      (10 элементов компонентного типа TLed)

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

for counter := 1 to 10 do
begin
LED[counter]:= TLED.Create;
LED[counter].top := ...
LED[counter].Left := ...
LED[counter].Parent := Mainform;   {что-то типа этого}
end;

Если компоненты уже присутствуют на форме (в режиме проектирования), сделайте их элементами массива, например так:

leds := 0;
for counter := 0 to Form.Componentcount do
begin
if (components[counter] is TLED) then
begin
inc(leds);
LED[leds] := TLED(components[counter]);
end
end;

Тем не менее у нас получился массив со случайным расположением LED-компонентов. Я предлагаю назначить свойству Tag каждого LED-компонента порядковый номер его расположения в массиве, а затем заполнить массив, используя это свойство:

for counter := 0 to Form.Componentcount do
begin
if (components[counter] is TLED) then
begin
LED[Component[counter].tag] := TLED(components[counter]);
end
end;

Если вам нужен двухмерный массив, то для формирования индекса понадобится другая хитрость, например, хранение в свойстве Hint информации о времени создания компонентов. [000055]


Массив компонентов II

Пришло ко мне письмо...

Вот что пишет по этому поводу Юрий Лапицкий:

Продолжая начатую тему в "Советах по Дельфи 1.0.9" о динамическом массиве компонентов (на этот раз двухмерном, так как одномерный очень хорошо был описан в этой версии журнала) я предлагаю следующей код который позволяет создать такой массив компонентов TImage с удобным (скажем так - почти) использованием их в этом массиве (например, при осуществлении связи с каким-то другим массивом). Я использовал этот код в одной из моих программ и после многих его тестов пришёл к выводу что он нормально работает при размерах массива 17х17 (думаю что можно довести и до 20х20 и более, но это увеличило бы код... Тем более что для моей программы такого массива вполне достаточно!).

{
Листинг 1: Создание двухмерного динамического массива компонентов
© 1999, Юрий Лапицкий
}

{
Шаг №1: Вначале, сделаем потомок стандартного TImage как дополнение для их различия в будующем массиве компонентов.
}
 type
TMyImage=class(TImage)
private
FXTag,FYTag: Longint;
published
property XTag: Longint read FXTag write FXTag default 0;
property YTag: Longint read FYTag write FYTag default 0;
end;
{===================}
{
Шаг №2: В описание класса главной формы вставим двухмерный динамический массив компонентов TMyImage, а в секцию private - необходимый код для инициализации массива!
}
 type
TForm1 = class(TForm)
procedure ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X,Y: Integer); //Процедура реализации события OnMouseUp при наведении на картинку
public
Images: array of array of TMyImage;
private
procedure MakeField(const MaxRows:byte=4; MaxCols:byte=4); {Процедура "создания" поля}
procedure FreeField(const MaxRows:byte=4; MaxCols:byte=4); {Процедура "убора" поля (вообще-то не обязательно, но я предпочитаю перестараться, чем недостараться...)}
end;
var
Form1: TForm1;
Bitmap1: TBitmap;
{
В Bitmap1 можно загрузить картинку. Например из файла Bitmap1.bmp:
Bitmap1:=TBitmap1.Create;
Bitmap1.LoadFromFile('Bitmap1.bmp');
}
{===================}
{
Шаг №3: Реализация процедур в секции implementation.
}
procedure TForm1.MakeField(const MaxRows,MaxCols:byte);
var Col,Row: byte;
begin
{Иницализация самого массива}
Initialize(Images);
System.SetLength(Images, MaxRows);
for Row:=0 to MaxRows-1 do System.SetLength(Images[Row], MaxCols);

{Создание и заполнение элементов массива}
for Row:=0 to MaxRows-1 do
for Col:=0 to MaxCols-1 do
begin
Images[Row,Col]:=TMyImage.Create(Self);
with Images[Row,Col] do
begin
XTag:=Row;
YTag:=Col;

Picture.Bitmap:=Bitmap1;
Left:= Col*Bitmap1.Width;
Top := Row*Bitmap1.Height;
Width  := Bitmap1.Width+Left;
Height := Bitmap1.Height+Top;
Center := True;
Transparent := True;
AutoSize := True;
Visible :=True;
onMouseUp:=ImageMouseUp;

Parent := Self;
end
end;

Invalidate
end;

procedure TMainForm.FreeField(const MaxRows, MaxCols: byte);
var Col,Row: byte;
begin
{Уничтожение элементов массива}
for Row:=0 to MaxRows-1 do
for Col:=0 to MaxCols-1 do
Images[Row,Col].Destroy;
{Уничтожение самого массива}
Finalize(Images)
end;

procedure TMainForm.ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X,Y: Integer);
begin
if (Sender is TMyImage) then { <-- Проверка необязательна, но ведь можно (случайно) присвоить это событие также и форме!}
begin
{
обратиться к элементу массива можно используя введённые мною дополнения: Sender.XTag и Sender.YTag
Images[Sender.XTag, Sender.YTag]
}
end
end;
[000188]


Delphi 1

Массив компонентов III

type
PtImg = ^TtImg;
TtImg = array [0..0] of TImage;
var
tImg: PtImg;

GetMem(tImg, 4 * numberofentries);

Преимущество в том, что вы должны использовать столько памяти, сколько вам нужно. Недостаток в том, что вы должны кодировать все с tImg^[n].... [000428]


Дублирование компонентов и их потомков во время выполнения приложения I

Приведенный ниже код содержит функцию DuplicateComponents, позволяющую проводить клонирование любых компонентов и их потомков во время выполнения приложения. Действия ее напоминают операцию копирования/вставки (copy/paste) во время разработки приложения. Новые компоненты при создании получают тех же родителей, владельцев (в случае применения контейнеров) и имена (естественно, несколько отличающихся), что и оригиналы. В данной функции есть вероятность багов, но я пока их не обнаружил. Ошибки и недочеты могут возникнуть из-за редко применяемых специфических методов, которые, вместе с тем, могут помочь программистам, столкнувшимися с аналогичными проблемами.

Данная функция может оказаться весьма полезной в случае наличия нескольких одинаковых областей на форме с необходимостью синхронизации изменений в течение некоторого промежутка времени. Процедура создания дубликата проста до безобразия: разместите на TPanel или на другом родительском компоненте необходимые элементы управления и сделайте: "newpanel := DuplicateComponents(designedpanel)".

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;

type
TUniqueReader = Class(TReader)
LastRead: TComponent;
procedure ComponentRead(Component: TComponent);
procedure       SetNameUnique(
Reader: TReader;
Component: TComponent;
var Name: string
);
end;

implementation

procedure TUniqueReader.ComponentRead(
Component: TComponent
);
begin
LastRead := Component;
end;

procedure TUniqueReader.SetNameUnique(  // Задаем уникальное имя считываемому компоненту, например, "Panel2", если "Panel1" уже существует
Reader: TReader;
Component: TComponent;              // Считываемый компонент
var Name: string                    // Имя компонента для дальнейшей модификации
);
var
i: Integer;
tempname: string;
begin
i := 0;
tempname := Name;
while Component.Owner.FindComponent(Name) <> nil do begin
Inc(i);
Name := Format('%s%d', [tempname, i]);
end;
end;

function DuplicateComponents(
AComponent: TComponent  // исходный компонент
): TComponent;              // возвращаемся к созданию нового компонента
procedure RegisterComponentClasses(
AComponent: TComponent
);
var
i : integer;
begin
RegisterClass(TPersistentClass(AComponent.ClassType));
if AComponent is TWinControl then
if TWinControl(AComponent).ControlCount > 0 then
for i := 0 to
(TWinControl(AComponent).ControlCount-1) do

RegisterComponentClasses(TWinControl(AComponent).Controls[i]);
end;

var
Stream: TMemoryStream;
UniqueReader: TUniqueReader;
Writer: TWriter;
begin
result := nil;
UniqueReader := nil;
Writer := nil;

try
Stream := TMemoryStream.Create;
RegisterComponentClasses(AComponent);

try
Writer := TWriter.Create(Stream, 4096);
Writer.Root := AComponent.Owner;
Writer.WriteSignature;
Writer.WriteComponent(AComponent);
Writer.WriteListEnd;
finally
Writer.Free;
end;

Stream.Position := 0;
try
UniqueReader := TUniqueReader.Create(Stream, 4096);     // создаем поток, перемещающий данные о компоненте в конструктор
UniqueReader.OnSetName := UniqueReader.SetNameUnique;
UniqueReader.LastRead := nil;

if AComponent is TWinControl then

UniqueReader.ReadComponents(
// считываем компоненты и суб-компоненты
TWinControl(AComponent).Owner,
TWinControl(AComponent).Parent,
UniqueReader.ComponentRead
)
else

UniqueReader.ReadComponents(
// читаем компоненты
AComponent.Owner,
nil,
UniqueReader.ComponentRead
);
result := UniqueReader.LastRead;
finally
UniqueReader.Free;
end;
finally
Stream.Free;
end;
end;
[000058]


Дублирование компонентов и их потомков во время выполнения приложения II

Модуль, клонирующий компонент:

-------------------------------------------------------- модуль Clone;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, Outline;

function Replicator(C: TComponent): TComponent;

implementation

{ Следующая процедура "клонирует" свойства C1 и записывает их в C2.
C1 и C2 должны иметь один и тот же тип. Используйте данный метод для компонентов, не имеющих метода Assign. }
procedure CloneComponent(C1: TComponent; C2: TComponent);
var
S: TMemoryStream;
begin
if C1.ClassType <> C2.ClassType then
raise EComponentError.Create('Типы объектов не совместимы');
if C1 is TWinControl then
TWinControl(C2).Parent := TWinControl(C1).Parent;
S := TMemoryStream.Create;   { создаем поток для работы с памятью }
with S do begin
WriteComponent(C1);         { пишем свойства C1 в поток }
Seek(0, 0);                 { перемещаемся в начало потока }
ReadComponent(C2);          { читаем свойства из потока в C2 }
Free;                       { освобождаем поток }
end;
end;

{ Следующая функция "реплицирует" компонент C и возвращает новый компонент типа и со свойствами компонента C. }

function Replicator(C: TComponent): TComponent;
begin
Result := TComponentClass(C.ClassType).Create(C.Owner);  { создаем компонент }
CloneComponent(C, Result);                               { клонируем его }
end;

end.

Вот как это использовать это:

var
BitBtn: TBitBtn;
begin
TComponent(BitBtn) := Replicator(BitBtn1);  { Если BitBtn1 уже существует }
end;

-- Xavier [000644]


Компонент TrayIcon

unit Trayicon;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, ShellAPI, Forms,
menus;
const WM_TOOLTRAYICON = WM_USER+1;
WM_RESETTOOLTIP = WM_USER+2;
type
TTrayIcon = class(TComponent)
private
// BDS
{ для внутреннего пользования }
hMapping: THandle;
{ Набор переменных }
IconData: TNOTIFYICONDATA;
fIcon : TIcon;
fToolTip : String;
fWindowHandle : HWND;
fActive : boolean;
fShowApp : boolean;                                     // Добавлено
fSendMsg : string;
fShowDesigning : Boolean;
{ События }
fOnClick     : TNotifyEvent;
fOnDblClick  : TNotifyEvent;
fOnRightClick : TMouseEvent;
fPopupMenu   : TPopupMenu;
function AddIcon : boolean;
function ModifyIcon : boolean;
function DeleteIcon : boolean;
procedure SetActive(Value : boolean);
procedure SetShowApp(Value : boolean);                  // Добавлено
procedure SetShowDesigning(Value : boolean);
procedure SetIcon(Value : TIcon);
procedure SetToolTip(Value : String);
procedure WndProc(var msg : TMessage);
procedure FillDataStructure;
procedure DoRightClick( Sender : TObject );
protected
public
FMessageID: DWORD;
constructor create(aOwner : TComponent); override;
procedure Loaded; override;                             // Добавлено
destructor destroy; override;
procedure GoToPreviousInstance;
published
property Active : boolean read fActive write SetActive;
property ShowDesigning : boolean read fShowDesigning write
SetShowDesigning;
property Icon : TIcon read fIcon write SetIcon;
property IDMessage : string read fSendMsg write fSendMsg;
property ShowApp : boolean read fShowApp write SetShowApp; // Добавлено
property ToolTip : string read fTooltip write SetToolTip;
property OnClick     : TNotifyEvent read FOnClick write FOnClick;
property OnDblClick  : TNotifyEvent read FOnDblClick write FOnDblClick;
property OnRightClick : TMouseEvent  read FOnRightClick write
FonRightClick;
property PopupMenu : TPopupMenu read fPopupMenu write fPopupMenu;
end;

procedure Register;

type
PHWND = ^HWND;

implementation

{$R TrayIcon.res}

procedure TTrayIcon.GoToPreviousInstance;
begin
PostMessage(hwnd_Broadcast, fMessageID, 0, 0);
end;

procedure TTrayIcon.SetActive(Value : boolean);
begin
if value <> fActive then begin
fActive := Value;
if not (csdesigning in ComponentState) then begin
if Value then begin
AddIcon;
end else begin
DeleteIcon;
end;
end;
end;
end;

procedure TTrayIcon.SetShowApp(Value : boolean);      // Добавлено
begin
if value <> fShowApp then fShowApp := value;
if not (csdesigning in ComponentState) then
begin
if Value then
begin
ShowWindow(Application.Handle, SW_SHOW);
end
else
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
end;
end;

procedure TTrayIcon.SetShowDesigning(Value : boolean);
begin
if csdesigning in ComponentState then begin
if value <> fShowDesigning then begin
fShowDesigning := Value;
if Value then begin
AddIcon;
end else begin
DeleteIcon;
end;
end;
end;
end;

procedure TTrayIcon.SetIcon(Value : Ticon);
begin
if Value <> fIcon then
begin
fIcon.Assign(value);
ModifyIcon;
end;
end;

procedure TTrayIcon.SetToolTip(Value : string);
begin
// Данная программа ВСЕГДА переустанавливает текст подсказки и перезагружает
// иконку. Текст может быть пустым в случае первой инициализации компонента.
// Без инициализации иконка будет пустой и текст подсказки будет отсутствовать.
if length( Value ) > 62 then
Value := copy(Value,1,62);
fToolTip := value;
ModifyIcon;
end;

constructor TTrayIcon.create(aOwner : Tcomponent);
begin
inherited create(aOwner);
FWindowHandle := AllocateHWnd( WndProc );
FIcon := TIcon.Create;
SetShowApp(False);
end;

destructor TTrayIcon.destroy;
begin
// BDS
CloseHandle(hMapping);

if (not (csDesigning in ComponentState) and fActive)
or ((csDesigning in ComponentState) and fShowDesigning) then
DeleteIcon;
FIcon.Free;
DeAllocateHWnd( FWindowHandle );
inherited destroy;
end;

procedure TTrayIcon.Loaded;
var
// BDS
// hMapping: HWND;
tmp, tmpID: PChar;
begin
inherited Loaded;
if fSendMsg <> '' then
begin
GetMem(tmp, Length(fSendMsg) + 1);
GetMem(tmpID, Length(fSendMsg) + 1);
StrPCopy(tmp, fSendMsg);
StrPCopy(tmpID, fSendMsg);
fMessageID := RegisterWindowMessage(tmp);
FreeMem(tmp);
hMapping := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32, tmpID);
if (hMapping <> NULL) and (GetLastError = ERROR_ALREADY_EXISTS) then
begin
if not (csDesigning in ComponentState) then
begin
GotoPreviousInstance;
FreeMem(tmpID);
halt;
end;
end;
FreeMem(tmpID);
end;
SetShowApp(fShowApp);
end;

procedure TTrayIcon.FillDataStructure;
begin
with IconData do begin
cbSize := sizeof(TNOTIFYICONDATA);
wnd := FWindowHandle;
uID := 0; // определенный приложением идентификатор иконки
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
hIcon := fIcon.Handle;
StrPCopy(szTip,fToolTip);
uCallbackMessage := WM_TOOLTRAYICON;
end;
end;

function TTrayIcon.AddIcon : boolean;
begin
FillDataStructure;
result := Shell_NotifyIcon(NIM_ADD,@IconData);
// По неизвестной причине, если не задан текст всплывающей
// подсказки, иконка не выводится. Здесь это учтено.
if fToolTip = '' then
PostMessage( fWindowHandle, WM_RESETTOOLTIP,0,0 );
end;

function TTrayIcon.ModifyIcon : boolean;
begin
FillDataStructure;
if fActive then
result := Shell_NotifyIcon(NIM_MODIFY,@IconData)
else
result := True;
end;

procedure TTrayIcon.DoRightClick( Sender : TObject );
var MouseCo: Tpoint;
begin
GetCursorPos(MouseCo);
if assigned( fPopupMenu ) then begin
SetForegroundWindow( Application.Handle );
Application.ProcessMessages;
fPopupmenu.Popup( Mouseco.X, Mouseco.Y );
end;
if assigned( FOnRightClick ) then
begin
FOnRightClick(self,mbRight,[],MouseCo.x,MouseCo.y);
end;
end;

function TTrayIcon.DeleteIcon : boolean;
begin
result := Shell_NotifyIcon(NIM_DELETE,@IconData);
end;

procedure TTrayIcon.WndProc(var msg : TMessage);
begin
with msg do
if (msg = WM_RESETTOOLTIP) then
SetToolTip( fToolTip )
else if (msg = WM_TOOLTRAYICON) then begin
case lParam of
WM_LBUTTONDBLCLK   : if assigned (FOnDblClick) then FOnDblClick(self);
WM_LBUTTONUP       : if assigned(FOnClick)then FOnClick(self);
WM_RBUTTONUP       : DoRightClick(self);
end;
end
else // Обработка всех сообщений с дескриптором по умолчанию
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;

procedure Register;
begin
RegisterComponents('Win95', [TTrayIcon]);
end;
end.
[000266]


Информация о версии (Version Info) в Delphi EXE

unit rpVersionInfo;  //версия 1.0 3/8/98 записана и проверена в Delphi 3.
(*Автор Rick Peterson, данный компонент распространяется свободно
и освобожден от платы за использование. В случае изменения
авторского кода просьба прислать измененный код. Сообщайте пожалуйста
обо всех найденных ошибках. Адрес для писем - rickpet@airmail.net. *)

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
TypInfo;

type
{$M+}
(* Видели директиву $M+??? Это заставляет Delphi включать в код RTTI-информацию для
перечислимых типов. В основном допускает работу с перечислимыми типами как
со строками с помощью GetEnumName *)
TVersionType=(vtCompanyName, vtFileDescription, vtFileVersion, vtInternalName,
vtLegalCopyright,vtLegalTradeMark, vtOriginalFileName,
vtProductName, vtProductVersion, vtComments);
{$M-}
TrpVersionInfo = class(TComponent)
(* Данный компонент позволяет получать информацию о версии вашего приложения
во время его выполенния *)
private
FVersionInfo : Array [0 .. ord(high(TVersionType))] of string;
protected
function GetCompanyName: string;
function GetFileDescription: string;
function GetFileVersion: string;
function GetInternalName: string;
function GetLegalCopyright: string;
function GetLegalTradeMark: string;
function GetOriginalFileName: string;
function GetProductName: string;
function GetProductVersion: string;
function GetComments: string;
function GetVersionInfo(VersionType: TVersionType): string; virtual;
procedure SetVersionInfo; virtual;
public
constructor Create(AOwner: TComponent); override;
published
(* Использовать это очень просто - Label1.Caption := VersionInfo1.FileVersion
Примечание: Все свойства - только для чтения, поэтому они недоступны в
Инспекторе Объектов *)
property CompanyName: string read GetCompanyName;
property FileDescription: string read GetFileDescription;
property FileVersion: string read GetFileVersion;
property InternalName: string read GetInternalName;
property LegalCopyright: string read GetLegalCopyright;
property LegalTradeMark: string read GetLegalTradeMark;
property OriginalFileName: string read GetOriginalFileName;
property ProductName: string read GetProductName;
property ProductVersion: string read GetProductVersion;
property Comments: string read GetComments;
end;

procedure Register;

implementation

constructor TrpVersionInfo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetVersionInfo;
end;

function TrpVersionInfo.GetCompanyName: string;
begin
result := GeTVersionInfo(vtCompanyName);
end;

function TrpVersionInfo.GetFileDescription: string;
begin
result := GeTVersionInfo(vtFileDescription);
end;

function TrpVersionInfo.GetFileVersion: string;
begin
result := GeTVersionInfo(vtFileVersion);
end;

function TrpVersionInfo.GetInternalName: string;
begin
result := GeTVersionInfo(vtInternalName);
end;

function TrpVersionInfo.GetLegalCopyright: string;
begin
result := GeTVersionInfo(vtLegalCopyright);
end;

function TrpVersionInfo.GetLegalTradeMark: string;
begin
result := GeTVersionInfo(vtLegalTradeMark);
end;

function TrpVersionInfo.GetOriginalFileName: string;
begin
result := GeTVersionInfo(vtOriginalFileName);
end;

function TrpVersionInfo.GetProductName: string;
begin
result := GeTVersionInfo(vtProductName);
end;

function TrpVersionInfo.GetProductVersion: string;
begin
result := GeTVersionInfo(vtProductVersion);
end;

function TrpVersionInfo.GetComments: string;
begin
result := GeTVersionInfo(vtComments);
end;

function TrpVersionInfo.GeTVersionInfo(VersionType: TVersionType): string;
begin
result := FVersionInfo[ord(VersionType)];
end;

procedure TrpVersionInfo.SeTVersionInfo;
var
sAppName,sVersionType : string;
iAppSize, iLenOfValue, i: integer;
pcBuf,pcValue: PChar;
begin
sAppName := Application.ExeName;
iAppSize:= GetFileVersionInfoSize(PChar(sAppName),iAppSize);
if iAppSize > 0 then
begin
pcBuf := AllocMem(iAppSize);
GetFileVersionInfo(PChar(sAppName),0,iAppSize,pcBuf);
for i := 0 to Ord(High(TVersionType)) do
begin
sVersionType := GetEnumName(TypeInfo(TVersionType),i);
sVersionType := Copy(sVersionType,3,length(sVersionType));
if VerQueryValue(pcBuf,PChar('StringFileInfo\040904E4\'+
sVersionType), Pointer(pcValue),iLenOfValue)
then
FVersionInfo[i] := pcValue;
end;
FreeMem(pcBuf,iAppSize);
end;
end;

procedure Register;
begin
RegisterComponents('FreeWare', [TrpVersionInfo]);
end;

end.
[000267]


Одной строкой

Исходные файлы VCL

НЕ изменяйте исходные файлы стандартной VCL, вы не сможете перекомпиллировать COMPLIB.DCL (он использует DCU-файлы, для которых у вас нет исходников). [000323]


Вложенные свойства

Для регистрации контейнерного класса в процедуре Register вы должны вызвать RegisterPropertyEditor. Приблизительно так:

RegisterPropertyEditor( TypeInfo( TYourContainedClass ),
TYourContainer,
'YourContainedPropery',
TClassProperty ) ;

Все это задокументировано в справке помощи по созданию компонентов. Первым всегда идет параметр TypeInfo() с контейнерным классом, затем сам контейнерный класс, затем имя контейнерного свойства, затем TClassProperty, который регистрирует расширение свойства класса.

А где взять реальный примерчик?

Посмотрите как это делаю я. Сохраните приведенный модуль с именем CONTAIN.PAS и добавите его к вашей палитре.

------------------------CONTAIN.PAS--------------------------------

unit Contain;

interface

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

type
TContainer = class( TComponent )
private
FImage : TImage ;
public
constructor Create( AOwner : TComponent ) ; override ;
published
property Image : TImage read FImage write FImage ;
end ;

procedure Register;

implementation

uses DsgnIntf ;

constructor TContainer.Create( AOwner : TComponent ) ;

begin
inherited Create( AOwner ) ;
FImage := TImage.Create( Self ) ;
end ;

procedure Register;
begin
RegisterComponents('Samples', [TContainer]);
RegisterPropertyEditor( TypeInfo( TImage ),
TContainer,
'Image',
TClassProperty ) ;
end;

end.

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

Это все?

Mike Scott
Mobius Ltd. [000414]


Delphi 1

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

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

constructor TMyComponent.Create(AOwner:TComponent);
begin
if SomeCondition then
raise Exception.Create('Не могу создать компонент');
inherited Create(AOwner);
.... дополнительная инициализация ...
end;

Pat [000470]


Чтение и запись компонента

Вот участок кода из предстоящей статьи о VBX/OCX, который я написал чтобы протестировать поточность своих компонентов. Если компонент поточнен, код сможет его сохранить и загрузить. В противном случае вы получите сообщение об ошибке, отладка которой сравнительна легка для определении проблем с VCL.

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

procedure TForm1.StoreClick(Sender: TObject); var W: TWriter; begin
W := TWriter.Create(
TFileStream.Create('c:\source\delphi\example.dob', fmCreate), 4096);
W.WriteSignature;
W.WriteComponent(Spin);
W.Free;
end;

procedure TForm1.LoadClick(Sender: TObject); var R: TReader; begin
R := TReader.Create(
TFileStream.Create('c:\source\delphi\example.dob', fmOpenRead), 4096);
Spin := R.ReadRootComponent(Nil) as TSpinner;
Spin.Top := 0;
Spin.Left := 0;
Spin.Parent := Self;
InsertComponent(Spin);
R.Free;
end;

===Blake=== [000493]


Delphi 1

Refresh или Repaint?

В файлах помощи написано, что REPAINT перед отрисовкой не очищает область элемента управления, а как быть, если мне это необходимо? Есть какое-то решение?

Попробуй добавить csOpaque в ControlStyle:

ControlStyle := ControlStyle + [ csOpaque ] ;

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

Mike Scott
Mobius Ltd. [000516]


Delphi 1

Имя класса компонента и модуля

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

Например: 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. [000546]


Delphi 1

Пример компонента "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 [000547]


Delphi 1

Копирование компонента через TFileStream

1) Существует способ присваивания всех свойств одного элемента управления (объекта) другому?

С определенными объектами, которые, обычно, являются обертками элементов управления Windows типа TFont и TBitmap, с помощью метода Assign, копирующего "внутренности" объекта. Вы можете сделать Font1.Assign( Font2 ). Тем не менее, такое возможно не со всеми объектами.

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

2) Как мне сохранить объект a) в записи в файле данных Paradox и б) в файле на диске?

Для записи на диск используйте поток. Объект должен быть компонентом и его можно записать на диск следующим образом:

var Stream : TFileStream ;
begin
Stream := TFileStream.Create( 'AFile', fmCreate ) ;
try
Stream.WriteComponent( Button1 ) ;
Stream.WriteComponent( Grid1 ) ; и т.д.
finally
Stream.Free ;
end ;
end ;

Для чтения объекта необходимо следующее:

var Stream : TFileStream ;
Button2 : TButton ;
Grid2 : TStringGrid ;
begin
Stream := TFileStream.Create( 'AFile', fmOpenRead ) ;
try
Button2 := Stream.ReadComponent( nil ) as TButton ;
Grid2 := Stream.ReadComponent( nil ) as TStringGrid ; и т.д.
finally
Stream.Free ;
end ;
end ;

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

RegisterClass( TButton ) ;
RegisterClass( TStringGrid ) ;

Если классы не зарегистрированы, то при попытке чтения объекта вы получите ошибку 'Class not found' (класс не найден).

Mike Scott.

Дополнение: если вы не хотите работать с чтением/записью в файл, то другой вариант работы с объектом - использование потока памяти (TMemoryStream). -- Xavier [000606]


Delphi 1

Прозрачный компонент

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

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

{  Начните с нового проекта.
Разместите на форме 4 кнопки и 1 компонент CheckBox.
Создайте обработчик события OnClick как показано ниже

Во время выполнения программы, если вы нажимаете на Button3, щелчок по Button1 будет перехватываться InvWin; если вы нажимаете на Button4, щелчок по Button2 будет перехватываться InvWin. Поскольку "невидимое" окно первоначально представляет собой простой дескриптор, элемент управления, расположенный под ним, должен быть перерисован. Из-за этого существует проблема мерцания, происходящая по сценарию как, будто вы щелкнули по Button3 и Button4. При щелчке на CheckBox1, InvWin.Invisible устанавливается в True. Это позволяет окну не перерисовываться. Поскольку окно у нас теперь истинно невидимое, то для устранения мерцания мы целенаправленно посылаем необходимым окнам сообщение WM_SETREDRAW. }
unit Invwin1;

interface

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

type
TInvWin = Class ( TWinControl )
Private
fOnControl : TControl;
fInvisible : Boolean;

Procedure WMPaint ( Var Message : TWMPaint ); message WM_PAINT;
Protected
Procedure CreateParams ( Var Params : TCreateParams ); override;
Procedure MouseDown ( Button : TMouseButton; Shift : TShiftState;
X, Y : Integer ); override;

Procedure SetOnControl ( Value : TControl ); virtual;
Public
Constructor Create ( aOwner : TComponent );

Property OnControl : TControl Read fOnControl Write SetOnControl;
Property Invisible : Boolean  Read fInvisible Write fInvisible;
End;

TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
CheckBox1: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
InvWin : TInvWin;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

Constructor TInvWin.Create ( aOwner : TComponent );
Begin
Inherited Create ( aOwner );

ControlStyle := ControlStyle + [csOpaque];
End;

Procedure TInvWin.CreateParams ( Var Params : TCreateParams );
Begin
Inherited CreateParams ( Params );

Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
End;

Procedure TInvWin.WMPaint ( Var Message : TWMPaint );
Var
DC : THandle;
PS : TPaintStruct;
Begin
If Not Invisible Then
Begin
If Message.DC = 0
Then DC := BeginPaint ( Handle, PS )
Else DC := Message.DC;

PatBlt ( DC, 0,         0,          5, 5, BLACKNESS );
PatBlt ( DC, Width - 6, 0,          5, 5, BLACKNESS );
PatBlt ( DC, 0,         Height - 6, 5, 5, BLACKNESS );
PatBlt ( DC, Width - 6, Height - 6, 5, 5, BLACKNESS );

If Message.DC = 0
Then EndPaint ( Handle, PS );
End;
End;

Procedure TInvWin.MouseDown ( Button : TMouseButton; Shift : TShiftState; X, Y
: Integer );
Begin
ShowMessage ( 'MouseDown над невидимым окном' );
End;

Procedure TInvWin.SetOnControl ( Value : TControl );
Var
Rect : TRect;
Begin
If Value <> fOnControl Then
Begin
{ Используйте только WM_SETREDRAW, если окно полностью невидимо }
If Invisible And ( Parent <> Nil ) Then Parent.Perform ( WM_SETREDRAW, 0, 0 );

If fOnControl <> Nil Then Visible := False;

If Value <> Nil Then
Begin
Rect := Value.BoundsRect;
InflateRect ( Rect, 2, 2 );
BoundsRect := Rect;
End;
fOnControl := Value;

If fOnControl <> Nil Then Visible := True;

{ Используйте только WM_SETREDRAW, если окно полностью невидимо }
If Invisible And ( Parent <> Nil ) Then Parent.Perform (WM_SETREDRAW, 1, 0 );
End;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
InvWin := TInvWin.Create ( Self );
InvWin.Visible := False;
InvWin.Parent := Self;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage ( 'MouseClick над Button1' );
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage ( 'MouseClick над Button2' );
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
InvWin.OnControl := Button1;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
InvWin.OnControl := Button2;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
InvWin.OnControl := Nil;
InvWin.Invisible := CheckBox1.Checked;
end;

end.

Robert Wittig [000749]


Delphi 1

Имплантация таймера в компонент

Я не могу разобраться как мне вставить TTimer в мой компонент и получить доступ к его методам и свойствам. Я нигде не могу найти пример такого использования таймера. Кто-нибудь может мне помочь?

Я просто создал это для вас:

type
TMyControl = class( TCustomControl )
private
FTimer : TTimer ;
procedure TimerEvent( Sender : TObject ) ;
public
constructor Create( AOwner : TComponent ) ; override ;
end ;

constructor TMyControl.Create( AOwner : TComponent ) ;
begin
inherited Create( AOwner ) ;
FTimer := TTimer.Create( Self ) ;
FTimer.Interval := 100 ; { 100 ms }
FTimer.OnTimer := TimerEvent ;
end ;

procedure TMyControl.TimerEvent( Sender : TObject ) ;
begin
{ вот ваш обработчик события, который вызывается при каждом
срабатывании таймера - делайте здесь все что вам необходимо }
end;

Легче не бывает! Правда, есть за что любить Delphi?

- Mike Scott [000762]


Связывание строки и компонента

Как связать строку с компонентом.

Имеется возможность связать строку с каждым компонентом?

Поскольку свойство Tag имеет тип longint, вы можете приводить его к свойству Pointer или PChar. Итак, вы можете хранить указатель на запись, используя свойство Tag.

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

var
i: integer;
begin
for i := 0 to ComponentCount - 1 do

if Components[i] is TEdit then
Components[i].Tag := LongInt(NewStr('Привет '+IntToStr(i)));
end;

Здесь мы организуем цикл и обходим все компоненты, расположенные на форме. Если компонент - TEdit, мы присваиваем указатель на строку свойству Tag. Функция NewStr возвращает PString (указатель на строку). Указатель, в основном, тождественен типу longint, или даже "лучше", т.е. занимает в памяти одинаковое количество байт. Следовательно, вы можете осуществить приведение к типу LongInt возвращаемому NewStr значению и сохранять его затем в свойстве Tag компонента TEdit. Имейте в виду, что это может быть указателем на целую запись. Теперь мы используем это значение:

var
i: integer;
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TEdit then begin
TEdit(Components[i]).Text := PString(Components[i].Tag)^;
DisposeStr(PString(Components[i].Tag));
end;
end;

Здесь я опять "пробегаюсь" по всем компонентам и работаю только с TEdits. На этот раз я извлекаю значение свойства компонента Tag, приводя его к типу PString (Pointer to a string, указатель на строку), и присваивая это значение свойству компонента TEdit Text. Естественно, в данном случае я должен использовать ключевой символ (^). После этого я избавляюсь от строки, хранимой в компоненте TEdit. Важное замечание: если вы храните что-либо в свойстве TEdit Tag как указатель, вы являетесь ответственным за освобождение его содержимого.

Для вашей информации: поскольку объекты Delphi реально являются указателями на экземпляры класса, вы можете хранить объекты в свойстве Tag. Вы, наверное, помните, что для этого необходимо вызвать метод Free.

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

  1. Если ваши строки никогда не меняются, вы можете создать строковый ресурс в Resource Workshop (или эквиваленте) и использовать Tag как индексы к таблице строк.
  2. Используйте TIniFile, создавайте секцию для ваших строк и присвойте каждой строке имя и число, т.е. ваш ini-файл должен иметь секцию типа такой:
      [strings]
  string1=Aristotle
  string2=Plato
  string3=Хорошо что это Delphi, в конце концов
    Затем вы можете к ним обратиться следующим образом:

    var s1: string;
    ...
    s1 := IniFile1.ReadString('strings', 'string'+IntToStr(Tag), '');

  3. Поместите ваши строки в файл, сопровождая каждую символом перевода строки. Затем вы можете прочесть их в TStringList. Затем ваши Tag'и становятся индексами в данном StringList:

    StringList1.LoadFromFile('slist.txt');
    ...
    s1 := StringList1[Tag];

Все три способа работают в Delphi, я я думаю это самое простое решение.

[000836]


Создание свойства-массива компонентов

У меня есть форма, на которой имеется около 20 компонентов CheckBox, и я хотел бы поочередно ссылаться на них как на элементы массива...

Вот способ использования свойства-массива. Здесь использована стандартная техника создания списка компонентов CheckBox в обработчике события OnCreate, позволяющая затем обращаться к ним как именно к массиву компонентов CheckBox.

Здесь я приведу два способа "собирания" CheckBox в одном массиве. Один просто собирает все CheckBox на форме. Это простой список, но вы должны убедиться в том, что порядок размещения в нем компонентов такой, каким вы хотите его видеть в массиве. Это нормально в данном случае. Другой способ перечисляет все компоненты согласно их нумерации, заложенной в их имени, но чтобы им воспользоваться, его необходимо раскоментарить. Существует множество других способов. Пусть данный совет послужит вам отправной точкой в изучении интересного вопроса оптимизации кода.

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FCheckboxes : TList ;
function GetCheckbox( Index : integer ) : TCheckbox ;
public
property Checkboxes[ Index : integer ] : TCheckbox read GetCheckbox ;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var i : integer ;
AComponent : TComponent ;
begin
FCheckboxes := TList.Create ;

{ ТАКЖЕ: это собирает все CheckBox в порядке очередности }
for i := 0 to ComponentCount - 1 do
if Components[ i ] is TCheckbox then
FCheckboxes.Add( Components[ i ] ) ;

{ ИЛИ: если они имеют имя CheckboxNN и вы хотите
разместить их в массиве в том же порядке... }
{for i := 1 to MaxInt do begin
AComponent := FindComponent( 'Checkbox' + IntToStr( i ) ) ;
if AComponent = NIL then break ;
FCheckboxes.Add( AComponent ) ;
end ;}
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
FCheckboxes.Free ;
end;

function TForm1.GetCheckbox( Index : integer ) : TCheckbox ;
begin
Result := TCheckbox( FCheckboxes[ Index ] ) ;
end ;

- Mike Scott [000888]


Компонент TMinMax

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

{***************************************************************************** }
{                                 UMINMAX.PAS }
{                                      Автор }
{                                Robert Wittig }
{                                  76401,242 }

{  Данный модуль обеспечивает вас интерфейсом для управления сообщением WM_GETMINMAXINFO }
{  на основе компонента . C помощью этого компонента вы легко можете управлять }
{  минимальным и максимальным размером окна. Вы можете также управлять размером и }
{  положением максимально раскрытого окна. }

{  Данный модуль свободен в использовании. Вы можете без ограничений использовать его }
{  в некоммерческих приложениях. Вы можете использовать его в коммерческих приложениях, }
{  если данный код занимает менее 20% от всего кода приложения. Вы можете свободно }
{  копировать и распространять данный модуль с условием сохранения (по возможности) }
{  данной информации. }

{  Пожалуйста посылайте свои коментарии/предложения автору непосредственно в форум }
{  или по e-mail по адресу 76401,242. Автор не дает никаких гарантий по работе }
{  данного модуля. }

{  История модуля }
{  ------------ }
{  03-05-96  Автор Robert Wittig (CompuServe ID 74601,242) }

{***************************************************************************** }
unit uMinMax;

interface
Uses Classes, Controls, Forms, Messages, SysUtils, WinProcs, WinTypes;

Type
TMinMax = Class ( TComponent )
Private
OldWndProc : Pointer;
FInstance  : Pointer;

MinMaxInfo : TMinMaxInfo;
FActive : Boolean;
Protected
Procedure Notification ( aComponent: TComponent; Operation: TOperation ); override;

Procedure ResetSubclass; virtual;
Procedure Subclass; virtual;

Procedure InitMinMaxInfo; virtual;
Procedure MinMaxWndProc ( Var Message : TMessage ); virtual;

Function  GetMinWidth  : Integer; virtual;
Function  GetMinHeight : Integer; virtual;
Function  GetMaxWidth  : Integer; virtual;
Function  GetMaxHeight : Integer; virtual;

Function  GetMaximizedX      : Integer; virtual;
Function  GetMaximizedY      : Integer; virtual;
Function  GetMaximizedWidth  : Integer; virtual;
Function  GetMaximizedHeight : Integer; virtual;

Function  GetReset : Boolean; virtual;

Procedure SetActive ( Value : Boolean ); virtual;

Procedure SetMinWidth  ( Value : Integer ); virtual;
Procedure SetMinHeight ( Value : Integer ); virtual;
Procedure SetMaxWidthWM_GETMINMAXINFO ( Value : Integer ); virtual;
Procedure SetMaxHeight ( Value : Integer ); virtual;

Procedure SetMaximizedX      ( Value : Integer ); virtual;
Procedure SetMaximizedY      ( Value : Integer ); virtual;
Procedure SetMaximizedWidth  ( Value : Integer ); virtual;
Procedure SetMaximizedHeight ( Value : Integer ); virtual;

Procedure SetReset ( Value : Boolean ); virtual;

Procedure SetNewSize; virtual;
Public
Destructor  Destroy; override;
Published
Property Active    : Boolean Read FActive      Write SetActive;

Property MinWidth  : Integer Read GetMinWidth  Write SetMinWidth;
Property MinHeight : Integer Read GetMinHeight Write SetMinHeight;
Property MaxWidth  : Integer Read GetMaxWidth  Write SetMaxWidth;
Property MaxHeight : Integer Read GetMaxHeight Write SetMaxHeight;

Property MaximizedX      : Integer Read GetMaximizedX      Write SetMaximizedX;
Property MaximizedY      : Integer Read GetMaximizedY      Write SetMaximizedY;
Property MaximizedWidth  : Integer Read GetMaximizedWidth  Write
SetMaximizedWidth;
Property MaximizedHeight : Integer Read GetMaximizedHeight Write
SetMaximizedHeight;

{**************************** RCW 03-05-96 ************************}
{ Reset является псевдо-свойством. Если значение равно True, TMinMax сбрасывает }
{ свойства Min/Max и устанавливает значения по умолчанию. }
{**************************** RCW 03-05-96 ************************}
Property Reset           : Boolean Read GetReset           Write SetReset;
End;

{********************************** RCW 03-05-96 ******************************}
{  Использование: Общая информация относительно WM_GETMINMAXINFO содержится }
{             в статьях WM_GETMINMAXINFO и TMINMAXINFO в файле справке }
{             по функциям API. Также, имейте в виду следующее: }
{               1) При перемещении границ окна минимальные/максимальные }
{                   размеры окна определяются свойствами MinWidth, MaxWidth,}
{                   MinHeight и MaxHeight. }

{               2) При максимизации окна максимальная высота и ширина }
{                   окна определяются соответственно Min(MaxHeight, }
{                   MaximizedHeight) и Min(MaxWidth,MaximizedWidth). Это }
{                   функция Windows и не зависит от работы компонента. }
{                   ( Примечание: возможно иметь окно, которое }
{                            имеет рамку большего размера чем максимальный }
{                            размер окна. )               }

{               3) Будьте осторожными при установке MaximizedX и MaximizedY. }
{                   Примечание: если вы установили это слишком маленьким }
{                   или слишком большим, ни кнопка, ни заголовок (для двойного }
{                   щелчка) видимыми не будут. Следовательно, вы не можете }
{                   восстановить окно до нормального состояния через нормальный }
{                   интерфейс Windows. }

{********************************** RCW 03-05-96 ******************************}

Procedure Register;

implementation

Procedure Register;
Begin
RegisterComponents ( 'Custom', [TMinMax] );
End;

Destructor TMinMax.Destroy;
Begin
If FInstance <> Nil
Then FreeObjectInstance ( FInstance );

Inherited Destroy;
End;

Procedure TMinMax.Notification ( aComponent: TComponent; Operation: TOperation );
Begin
If aComponent = Self
Then If Operation = opInsert
Then Subclass
Else If Operation = opRemove
Then ResetSubclass;

Inherited Notification ( aComponent, Operation );
End;

Procedure TMinMax.ResetSubclass;
Begin
If ( FInstance <> Nil ) And
( Owner <> Nil )
Then If IsWindow ( TWinControl(Owner).Handle )
Then SetWindowLong ( TWinControl(Owner).Handle, GWL_WNDPROC,
LongInt ( OldWndProc ) );
End;

Procedure TMinMax.Subclass;
Begin
If Owner Is TWinControl
Then With TWinControl(Owner) Do
Begin
If FInstance = Nil
Then FInstance := MakeObjectInstance ( MinMaxWndProc );
OldWndProc := Pointer ( GetWindowLong ( Handle, GWL_WNDPROC ) );
SetWindowLong ( Handle, GWL_WNDPROC, LongInt ( FInstance ) );
InitMinMaxInfo;
End;
End;

Procedure TMinMax.InitMinMaxInfo;
Begin
With MinMaxInfo Do
Begin
If Owner Is TForm
Then With ptMaxPosition Do
Case TForm(Owner).BorderStyle Of
bsSingle : Begin
X := -GetSystemMetrics ( SM_CXBORDER );
Y := -GetSystemMetrics ( SM_CYBORDER );
End;
bsSizeable : Begin
X := -GetSystemMetrics ( SM_CXFRAME );
Y := -GetSystemMetrics ( SM_CYFRAME );
End;
End;

With ptMaxSize Do
Begin
X := Screen.Width  - 2 * ptMaxPosition.X;
Y := Screen.Height - 2 * ptMaxPosition.Y;
End;

ptMaxTrackSize := ptMaxSize;
End;
End;

Procedure TMinMax.MinMaxWndProc ( Var Message : TMessage );
Begin
Message.Result := CallWindowProc ( TFarProc(OldWndProc), TWinControl(Owner).Handle,
Message.Msg, Message.wParam, Message.lParam );

If FActive And ( Message.Msg = WM_GETMINMAXINFO )
Then PMinMaxInfo ( Message.lParam )^ := MinMaxInfo;
End;

Function TMinMax.GetMinWidth : Integer;
Begin
Result := MinMaxInfo.ptMinTrackSize.X;
End;

Function TMinMax.GetMinHeight : Integer;
Begin
Result := MinMaxInfo.ptMinTrackSize.Y;
End;

Function TMinMax.GetMaxWidth : Integer;
Begin
Result := MinMaxInfo.ptMaxTrackSize.X;
End;

Function TMinMax.GetMaxHeight : Integer;
Begin
Result := MinMaxInfo.ptMaxTrackSize.Y;
End;

Function TMinMax.GetMaximizedX : Integer;
Begin
Result := MinMaxInfo.ptMaxPosition.X;
End;

Function TMinMax.GetMaximizedY : Integer;
Begin
Result := MinMaxInfo.ptMaxPosition.Y;
End;

Function TMinMax.GetMaximizedWidth : Integer;
Begin
Result := MinMaxInfo.ptMaxSize.X;
End;

Function TMinMax.GetMaximizedHeight : Integer;
Begin
Result := MinMaxInfo.ptMaxSize.Y;
End;

Function TMinMax.GetReset : Boolean;
Begin
Result := False;
End;

Procedure TMinMax.SetActive ( Value : Boolean );
Begin
If Value <> FActive
Then Begin
FActive := Value;
SetNewSize;
End;
End;

Procedure TMinMax.SetMinWidth ( Value : Integer );
Begin
If Value < 0
Then Value := 0;

If Value <> MinMaxInfo.ptMinTrackSize.X
Then Begin
MinMaxInfo.ptMinTrackSize.X := Value;
SetNewSize;
End;
End;

Procedure TMinMax.SetMinHeight ( Value : Integer );
Begin
If Value < 0
Then Value := 0;

If Value <> MinMaxInfo.ptMinTrackSize.Y
Then Begin
MinMaxInfo.ptMinTrackSize.Y := Value;
SetNewSize;
End;
End;

Procedure TMinMax.SetMaxWidth ( Value : Integer );
Begin
If Value < MinMaxInfo.ptMinTrackSize.X
Then Value := MinMaxInfo.ptMinTrackSize.X;

If Value <> MinMaxInfo.ptMaxTrackSize.X
Then Begin
MinMaxInfo.ptMaxTrackSize.X := Value;
SetNewSize;
End;
End;

Procedure TMinMax.SetMaxHeight ( Value : Integer );
Begin
If Value < MinMaxInfo.ptMinTrackSize.Y
Then Value := MinMaxInfo.ptMinTrackSize.Y;

If Value <> MinMaxInfo.ptMaxTrackSize.Y
Then Begin
MinMaxInfo.ptMaxTrackSize.Y := Value;
SetNewSize;
End;
End;

Procedure TMinMax.SetMaximizedX ( Value : Integer );
Begin
MinMaxInfo.ptMaxPosition.X := Value;
End;

Procedure TMinMax.SetMaximizedY ( Value : Integer );
Begin
MinMaxInfo.ptMaxPosition.Y := Value;
End;

Procedure TMinMax.SetMaximizedWidth ( Value : Integer );
Begin
MinMaxInfo.ptMaxSize.X := Value;
End;

Procedure TMinMax.SetMaximizedHeight ( Value : Integer );
Begin
MinMaxInfo.ptMaxSize.Y := Value;
End;

Procedure TMinMax.SetReset ( Value : Boolean );
Begin
If Value
Then InitMinMaxInfo;
End;

Procedure TMinMax.SetNewSize;
Begin
If Not FActive
Then Exit;

{**************************** RCW 03-05-96 ******************************}
{ Если размер окна превышает допустимые пределы, производим необходимую коррекцию. }
{****************************** RCW 03-05-96 ****************************}
If FInstance = Nil
Then Raise Exception.Create ( 'Не могу управлять WM_GETMINMAXINFO, поскольку
Owner не TWinControl' )
Else With TWinControl(Owner), MinMaxInfo Do
Begin
If ( ptMinTrackSize.X <> 0 ) Or
( ptMaxTrackSize.X <> 0 )
Then If Width < ptMinTrackSize.X
Then Width := ptMinTrackSize.X
Else If Width > ptMaxTrackSize.X
Then Width := ptMaxTrackSize.X;

If ( ptMinTrackSize.Y <> 0 ) Or
( ptMaxTrackSize.Y <> 0 )
Then If Height < ptMinTrackSize.Y
Then Height := ptMinTrackSize.Y
Else If Height > ptMaxTrackSize.Y
Then Height := ptMaxTrackSize.Y;
End;
End;

end.

- Robert Wittig [000925]


Создание порядка компонент - решено!

Благодаря Ray Konopka, я обнаружил, что в документации свойство ComponentIndex *не* имеет атрибута "только для чтения". При установке ComponentIndex все существующие компоненты с данным индексом или выше устанавливали ComponentIndex равным предыдущему значению, увеличенному на единицу. Например, если у вас имеются три компонента: CompA, CompB, и CompC с индексами 1, 2 и 3 соответственно, то при добавлении CompD и установке у него ComponentIndex равным 2, порядок компонентов будет следующим: CompA, CompD, CompB, CompC (индексы 1, 2, 3 и 4 соответственно).

- Jim Fralix [000926]


Delphi 1

Показ всплывающих подсказок компонентов

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

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DB, DBTables, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private { Private-Deklarationen }
public  { Public-Deklarationen }
procedure DoShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.DoShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
with HintInfo do
if HintControl = Button1 then begin
HintPos.X := Left + Button1.Left;
HintPos.Y := Top  + (Button1.Top);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := DoShowHint;
end;

end.

- Ralph Friedman [000951]


Элементы управления с автовыравниванием?

Я просто хочу в моем модуле заставить перемещаться поле редактирования (компонент Edit) синхронно с перемещением кнопки. При любом перемещении поля редактирования кнопка должна следовать за ним. Покопался в исходном коде VCL, но так ничего и не обнаружил...

При создании кнопки вы должны сделать ее "ребенком" поля редактирования (обычно, parent := self;). Также для компонента вы должны перекрыть метод CreateParams и установить Param.Style следующим образом:

Params.Style or WS_CLIPCHILDREN;

- Ralph Friedman [000987]


Delphi 1

Деактивация приложения

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

Application.OnDeactivate=AppDeactivate;

Затем создайте следующий метод:

procedure Form1.AppDeactivate(Sender: TObject);
begin
.
{ здесь ваш код}
.
end;

HopeThis Helps
Marco Romanini
Delphi Tech Support [000396]


Delphi 1

Загрузка иконки

Если ваша иконка хранится в компоненте Image (видимым или иным способом), вы можете написать:

Application.Icon := Image1.Picture.Icon;

Если в файле ресурса:

Application.Icon.Handle := LoadIcon(hInstance, 'ICONNAME');

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

InvalidateRect(Application.Handle, NIL, True);

.. и новая иконка предстанет свету.

Иконка, расположенная в .RES-файле, должна быть видима в .EXE-файле, к примеру, при просмотре файла посредством Program Manager. Иконка, расположенная в компоненте Image, в этом случае не видна.

- Neil [000401]


Для чего нужен ProcessMessages?

Многие начинающие программисты не знают о методе Application.ProcessMessages() и сталкиваются с проблемами, которых не могут объяснить. Например хотим написать что-то на форме и через 5 секунд стереть.

Нужно сделать так:

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption:='Started';
Application.ProcessMessages();
sleep(1000);
Label1.Caption:='Finished';
end;

Попробуйте убрать Application.ProcessMessages() и 'Started' вы никогда не увидите, это связано с тем, что Windows ждет пока накопятся задачи в очереди а не выполняет их сразу, Application.ProcessMessages() заставляет выполнить все задачи которые накопились в данный момент. Подробнее читайте в Help.

Это также можно применить в таком примере:

procedure TForm1.Button1Click(Sender: TObject);
var i: integer;
begin
for i:=1 to 100000 do Application.ProcessMessages();
end;

если не будет ProcessMessages() то пока крутится цикл мы не сможем сдвинуть или свернуть форму.

Прислал Alexander Vozny. [000485]


Delphi 1

Окно активное и окно с фокусом

"Активное" окно - это самое верхнее окно, принадлежащее "активному" приложению, или приложению, получающему сообщения от нажатий клавиш. Окно с фокусом - единственное окно, которому посылаются сообщения о нажатых клавишах.

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

Поэтому то, что использовать - GetActiveWindow или GetFocus, всецело зависит от того, что вы собираетесь сделать. Тем не менее, я догадываюсь, GetFocus будет использован чаще, но не всегда. [000505]


Одной строкой

Больше цветов!

Тип TColor - это простой LongInt, поэтому вы можете устанавливать цвета, какие душе угодно:

Canvas.Font.Color := $00FFCC88;

Кстати, таким же способом можно задавать значение цвета и в Инспекторе Объектов во время разработки приложения. [000478]


Поиск строки текста в наследниках TCustmoEdit

Пришло мне письмо. От Aleksey (msalex@tomcat.ru). На этот раз он прислал (цитирую): "юнит для поиска строки(текста) в TEdit, TMemo, или других компонентах (дочерних TCustomEdit'у)." Так как тескт "авторский" (более того, здесь также присутствует "наследование), помещаю его здесь в том виде, в котором он был прислан, т.е. без перевода. В случае каких-либо вопросов и недоразумений обращайтесь по вышеуказанносу адресу электронной почты.

{ПРИМЕР :

[...]

implementation
uses Search;
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
SearchMemo(RichEdit1, 'Найди меня', [frDown]);
end;

В опции поиска можно подключать, отключать, комбинировать следующие
параметры:
frDown - указывает на то, что происходит поиск вниз по тексту от курсора(при
отключенном frDown'е будет происходит поиск вверх по тексту).
frMatchCase - указывает на то, что следует проводить поиск с учетом
регистра.
frWholeWord - указывает на то, что следует искать только слово целиком.
[...]

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

unit Search;

interface

uses
WinProcs, SysUtils, StdCtrls, Dialogs;

const
{****************************************************************************
* Default word delimiters are any character except the core alphanumerics. *
****************************************************************************}
WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0'];
{******************************************************************************
* SearchMemo scans the text of a TEdit, TMemo, or other TCustomEdit-derived  *
* component for a given search string. The search starts at the current      *
* caret position in the control.  The Options parameter determines whether   *
* the search runs forward (frDown) or backward from the caret position,      *
* whether or not the text comparison is case sensitive, and whether the      *
* matching string must be a whole word.  If text is already selected in the  *
* control, the search starts at the 'far end' of the selection (SelStart if  *
* searching backwards, SelEnd if searching forwards).  If a match is found,  *
* the control's text selection is changed to select the found text and the   *
* function returns True.  If no match is found, the function returns False.  *
******************************************************************************}
function SearchMemo(Memo: TCustomEdit;
const SearchString: String;
Options: TFindOptions): Boolean;
{******************************************************************************
* SearchBuf is a lower-level search routine for arbitrary text buffers.      *
* Same rules as SearchMemo above. If a match is found, the function returns  *
* a pointer to the start of the matching string in the buffer. If no match,  *
* the function returns nil.                                                  *
******************************************************************************}
function SearchBuf(Buf: PChar; BufLen: Integer;
SelStart, SelLength: Integer;
SearchString: String;
Options: TFindOptions): PChar;

implementation

function SearchMemo(Memo: TCustomEdit;
const SearchString: String;
Options: TFindOptions): Boolean;
var
Buffer, P : PChar;
Size : Word;
begin
Result := False;
if (Length(SearchString) = 0) then
Exit;
Size := Memo.GetTextLen;
if Size = 0 then
Exit;
Buffer := StrAlloc(Size + 1);
try
Memo.GetTextBuf(Buffer, Size + 1);
P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength, SearchString, Options);
if P <> nil then
begin
Memo.SelStart := P - Buffer;
Memo.SelLength := Length(SearchString);
Result := True;
end;
finally
StrDispose(Buffer);
end;
end;

function SearchBuf(Buf: PChar; BufLen: Integer;
SelStart, SelLength: Integer;
SearchString: String;
Options: TFindOptions): PChar;
var
SearchCount, I: Integer;
C : Char;
Direction : Shortint;
CharMap: array [Char] of Char;

function FindNextWordStart(var BufPtr: PChar) : Boolean;
begin                   { (True XOR N) is equivalent to (not N) }
//    Result := False;      { (False XOR N) is equivalent to (N)    }
{ When Direction is forward (1), skip non delimiters, then skip delimiters. }
{ When Direction is backward (-1), skip delims, then skip non delims }

while (SearchCount > 0) and
((Direction = 1) xor
(BufPtr^ in WordDelimiters)) do
begin
Inc(BufPtr, Direction);
Dec(SearchCount);
end;

while (SearchCount > 0) and
((Direction = -1) xor
(BufPtr^ in WordDelimiters)) do
begin
Inc(BufPtr, Direction);
Dec(SearchCount);
end;

Result := SearchCount > 0;
if Direction = -1 then
begin {back up one char, to leave ptr on first non delim}
Dec(BufPtr, Direction);
Inc(SearchCount);
end;
end;

begin
Result := nil;

if BufLen <= 0 then
Exit;

if frDown in Options then
begin {if frDown...}
Direction := 1;
Inc(SelStart, SelLength);  { start search past end of selection }
SearchCount := BufLen - SelStart - Length(SearchString);

if SearchCount < 0 then
Exit;

if Longint(SelStart) + SearchCount > BufLen then
Exit;

end {if frDown...}
else
begin {else}
Direction := -1;
Dec(SelStart, Length(SearchString));
SearchCount := SelStart;
end; {else}

if (SelStart < 0) or (SelStart > BufLen) then
Exit;

Result := @Buf[SelStart];
{ Using a Char map array is faster than calling AnsiUpper on every character }
for C := Low(CharMap) to High(CharMap) do
CharMap[C] := C;

if not (frMatchCase in Options) then
begin {if not (frMatchCase}
AnsiUpperBuff(PChar(@CharMap), sizeof(CharMap));
AnsiUpperBuff(@SearchString[1], Length(SearchString));
end; {if not (frMatchCase}

while SearchCount > 0 do
begin {while SearchCount}
if frWholeWord in Options then
begin
if not FindNextWordStart(Result) then
Break;
end;
I := 0;

while (CharMap[Result[I]] = SearchString[I+1]) do
begin {while (CharMap...}
Inc(I);
if I >= Length(SearchString) then
begin {if I >=...}
if (not (frWholeWord in Options)) or
(SearchCount = 0) or
(Result[I] in WordDelimiters) then
Exit;
Break;
end; {if I >=...}
end; {while (CharMap...}

Inc(Result, Direction);
Dec(SearchCount);
end; {while SearchCount}

Result := nil;
end;

end.
[000109]


Delphi 1

Информация о TDataLink

Вот тексовое описание TDatalink, которое взято из моего учебного материала. Оригинал имеет еще несколько диаграмм и рисунков, которые не могут быть включены в данный совет. Также рекомендую заглянуть в исходный код модуля DB.PAS.

TFieldDatalink - производный класс от TDataLink, являющийся базовым классом для объекта, используемого компонентами для работы с базами данных и осуществляющий функцию связи с набором данных DataSet (TTable или TQuery). DataLink используется DataSet'ом для информирования всех БД-компонентов об изменении записи, о необходимости обновления записи перед помещением ее в базу данных, о том, что DataSet сменила свое состояние на активное или неактивное, и т.д.. И наоборот, DataLink используется БД-компонентами для обновления DataSet, например, его статуса.

DataSet может быть связан с несколькими источниками данных DataSource, каждый DataSource может быть связан с несколькими DataLink, и каждый DataLink может быть связан с единственным БД-компонентом. В большинстве случаев, отдельный компонент использует только один DataLink, тем не менее, имеются компоненты, такие как, например, DBLookupList или DBLookupCombo, использующих два DataLink. В этих элементах управления первый DataLink используется для чтения данных из lookup DataSet, второй DataLink используется для записи этих данных (при их изменении) во второй имеющийся DataSet. Каждый DataSet поддерживает связанный с ним список DataSource и, аналогично этому, каждый DataSource поддерживает список связанных с ним Datalink'ов.

В момент, когда DataSet должен уведомить БД-компоненты о наступлении какого-то события, например, при изменении пользователем какой-либо записи, он рассылает это сообщение всем DataSource, находящимся в его списке. Каждый DataSource затем повторяет этот процесс и рассылает сообщение всем Datalink'ам, находящимся в его списке. Другими словами, связь не зависит от элемента управления, при этом логика программирования должна отслеживать передачу сообщения каждому элементу управления, пользующемуся услугами DataLink и изолировать только те события, на которые элементу необходимо отреагировать. Связывая компонент с набором данных другим способом, мы не получим в свое распоряжение столько управляющих функций, гибкости и мониторинга, сколько даст нам один DataSet, соединенный с помощью DataLink.

Кроме функции обеспечения поддержания коммуникационного канала между DataSet и ДБ-компонентами, DataLink также обеспечивает управление буфером для каждого компонента. Большинство элементов управления, таких как, например, TDBEdit, отображающий только отдельно взятую запись, буферизация не требуется, тем не менее, таким компонентам, как, например, TDBGrid и TDBLookupList, отображающим множество записей, буферизация нужна. Физически DataLink данные не буферизирует, эта функция выполняется DataSet. Всесто этого DataLink поддерживает виртуальный буфер, который, в сущности, небольшое "окно" в физический буфер DataSet. Размер этого виртуального буфера может быть установлен с помощью свойства DataLinks BufferCount, а количество записей, реально в нем хранимых, с помощью свойства RecordCount.

James Thorpe
CSA Australasia [000751]


Одной строкой

Dos Copy через TFileStream

Var
S,T: TFileStream;

Begin
S:=TFileStream.Create( sourcefilename, fmOpenRead );
try
T:=TFileStream.Create( targetfilename, fmOpenWrite );
try
T.CopyFrom(S, S.Size ) ;
finally
T.Free;
end;
finally
S.Free;
end;
End;
[000521]


Delphi-приложения без форм?

Почему нет? Во-первых, откройте пункт меню File|New Project и выберите "CRT Application" из диалога "Browse Gallery". Delphi создаст проект, который все еще Windows-программа, но функции WriteLn, ReadLn уже работают так же, как и в сеансе DOS. Если хотите, удалите модуль WinCrt из списка используемых модулей (если не требуется ввода/вывода данных, но данный модуль необходим для качественной отладки).

Я сделал это ради любопытства, было интересно посмотреть на размер получившегося приложения. Я смог создать простейший EXE-файл (фантастика!) размером всего-лишь 3200, или около того, байтов! На днях попытаюсь сделать тоже самое в C++!

BTW, эти "бесформенные" приложения все еще являются Windows-приложениями, поэтому они без проблем могут пользоваться Windows API функциями. Для этого необходимо добавить в список используемых модулей модули WinProcs и WinTypes. Также вы, вероятно, захотите добавить SysUtils и другие, необходимые вам модули.

[000092]


Показ логотипа при запуске приложения I

Это очень просто.

Создайте форму и поместите на нее логотип, используя компонент Timage. В моем примере я создал форму с логотипом и именем "logoform". Зайдите в настройки проекта и исключите форму их списка "автосоздаваемых" форм.

Затем в вашем файле PROJECT.DPR где-то сразу после ключевого слова begin напишите примерно следующее:

logoform := TLogoform.Create(nil);
logoform.Show;            { ВНИМАНИЕ! show!   НЕ showmodal }

.
. { Здесь может размещаться код инициализации приложения, например, открытие базы данных... }
.

.  { После блока кода, создающего все ваши формы и перед
строчкой Application.Run напишите: }
logoform.Hide;
logoform.Release;

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

A вот Алексей (msalex@tomcat.ru) показал более изящный способ:

program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
ULogo in 'ULogo.pas' {LogoForm};

{$R *.RES}

begin Application.Initialize; {до этого момента никаких изменений}
with TLogoForm.Create(Application) do
try
Show;
Update;
Application.CreateForm(TForm1, Form1);
{GProgress.AddProgress(1); - здесь можно двигать прогресс, если TGauge
или TProgressBar лежат на TLogoForm'е}
{если есть еще формы, то Application.CreateForm(TForm2, Form2); и т.д.}
finally
Free;
end;
Application.Run;
end.
[000093]


Delphi 1

Показ логотипа при запуске приложения II

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

После моего хирургического вмешательства осталось всего пять или шесть строк кода, вплетенных в скелет формы. После сравнения моего кода с демо-проектом, поставляемым с Delphi (MastApp), я понял, что мой код много проще.

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

Код производит впечатление, что создание окошка с логотипом в Delphi плевое дело. Ну за дело: сначала, с помощью редактора, создайте форму (лучшим решением будет создание нового проекта в отдельном каталоге) и установите лучшие, на ваш художественный взгляд, значения таких свойств, как позиция, размеры и границы. Затем создайте обработчик события OnDeactivate и добавьте единственную строчку кода, в которой мы освобождаем форму. И, последнее, добавьте секцию initialization с тремя строчками кода, которые создают, выводят и обновляют форму.

Для того, чтобы использовать новое окошко с логотипом, скопируйте получившийся .PAS-файл в каталог с проектом, в котором вы намереваетесь его использовать, и вставьте ссылку на модуль в самую верхнюю часть секции uses. НЕ добавляйте форму к проекту.

Ниже приведен пример кода (форма имеет имя SplashForm, модуль обозван как SPLASH). Мой код добавлен между закомментаренных блоков {>>вставить} и {<<конец вставки}, весь остальной код генерируется Delphi.

Type
TSplashForm = class(TForm)
[...labels, bitmaps, и пр., добавляется редактором Delphi...]
procedure FormDeactivate(Sender: TObject);
end;

var
SplashForm:  TSplashForm;

implementation

{$R *.DFM}

{ Это шаманское место. Application.Run в нашем случае вызывает программу деактивации.}   procedure TSplashForm.FormDeactivate(Sender: TObject);
begin
{>>вставить}
Free;
{<<конец вставки}
end;

{>>вставить}
initialization
begin
SplashForm := TSplashForm.Create(nil);
SplashForm.Show;

{ Я не уверен, но причина наличия здесь Update в том, что, как мне кажется, приложение пока не может работать c очередью своих сообщений}
SplashForm.Update;
end;
{<<конец вставки} end.

В головном модуле после строчки USES (.DPR-файл) просто добавьте "SPLASH," (не заключайте это в кавычки). Это все. Никакой головной боли с таймерами, никаких запусков отдельных приложений. Логотип быстро появляется и остается до тех пор, пока приложение не начнет свою работу.

- Howard Harkness [000747]


Перемещение формы не за заголовок I

Перетаскивание границ окна

Это описание одного из Борландовских советов:

В: Как я могу заставить форму перемещаться, щелкая и таская ее в области окна, исключая заголовок?

О: Простейший путь - "одурачить" окно, пусть оно думает, что его тастают за заголовок. Сделайте это с помощью системного сообщения wm_NCHitTest...

type
TForm1 = class(TForm)
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;

var
Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;                   { вызов унаследованного обработчика события   }
if M.Result = htClient then  { кликнув в области окна?                     }
M.Result := htCaption;     { если так, то мы заставили Windows думать,   }
{ что щелчок был на заголовке окна.           }
end;

Перетаскивание окна с содержимым

После того, как я воспользовался вашим кодом, окно осталось на том же месте, таскался лишь его контур. Как изменить это так, чтобы при перетаскивании сохранялось содержимое окна (подобно win95 plus)?

Вот небольшой простой компонент, работающий по этому принципу...

Unit WinDrag;

interface

uses windows, sysutils, classes, dsgnintf;

type
TWinDrag = class(TComponent)
private
{ Private Declarations }
protected
{ Protected Declarations }
public
{ Public Declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetDragFlag: boolean;
procedure SetDragFlag(Status: Boolean);
published
Property DragFlag: Boolean read GetDragFlag write SetDragFlag;
end;

procedure Register;

implementation

constructor TWinDrag.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DragFlag := GetDragFlag;
end;

destructor TWinDrag.Destroy;
begin
inherited Destroy;
end;

function TWinDrag.GetDragFlag: boolean; var Value : Boolean; begin
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @Value, 0);
Result := Value;
end;

procedure TWinDrag.SetDragFlag(Status: Boolean);
begin
SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Integer(Status),
POINTER(0), 0);
end;

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

end.

Перетаскивание формы, удерживая компонент Label

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

var
X1, Y1: Integer;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
{Устанавливаем координаты старта}
X1 := X;
Y1 := Y;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
{Проверяем нажатие левой кнопки мыши}
if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then
begin
Form1.Left := Form1.Left + X - X1;
Form1.Top := Form1.Top + Y - Y1;
end;
end;

[000094]


Перемещение формы не за заголовок II

Sergey Matveychuk пишет:

Я нашел более компактный способ перемещения формы не за заголовок. При этом можно обойтись обработкой только события OnMouseDown. Перетаскивать форму можно за любой элемент, который находится на ней. Для этого создайте обработчик OnMouseDown для элементов, за которые хотите перетаскивать форму (и/или для самой формы). Вот пример для Panel:

procedure TForm1.PanelMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DRAGMOVE : Longint = $F012;
begin
if Button <> mbRight then
begin
ReleaseCapture;
SendMessage(Handle, WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;
end;

Сергей Матвейчук. [000895]


Помещение 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 в заголовок окна, точнее, не существует никакого способа установить их там."

Зато существует иллюзия...

[000096]


Сохранение 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;

[000097]


Удаление иконки из панели задач

ShowWindow (Application.Handle, SW_HIDE);
[000098]


Как мне спрятать заголовок формы??

Во-первых, перепишите у формы метод "CreateParams", объявив его в protected или public секции:

procedure CreateParams(var Params: TCreateParams); override;

Затем создайте сам код метода CreateParams(), выглядящий так:

procedure TForm1.Createparams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
end;

Надо надеяться, что вы обеспечите некоторый UI-механизм для перемещения и закрытия окна. [000099]


Плавающие панельки

Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (FreeDoc)? Я попробовал и вот что получилось...

Код требует использования некоторых функций WinAPI. Описание всех WinAPI функций доступны при нажатии F1 (электронная справка)...

Ну а теперь попробуем это создать (весь код занимает около 100 строчек)...

Ход работы:

Стартуйте новый проект, задайте свойству borderstyle формы значение bsNone, добавьте панель, установите у нее свойство borderstyle равным значению bsSingle, добавьте другую панель с любым заголовком, добавьте кнопку с подсказкой 'переключатель панели заголовка', вырежьте из данного совера код и вставьте его в модуль, создайте обработчики трех событий панелей (MouseDown, MouseMove, MouseUp) и один обработчик кнопки (Click). Надеюсь, что ничего не забыл... ;-) Быстрее сделать это в Delphi, чем написать здесь... ;-)

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Button1: TButton;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
OldX,
OldY,
OldLeft,
OldTop   : Integer;
ScreenDC : HDC;
MoveRect : TRect;
Moving   : Boolean;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
SetCapture(Panel1.Handle);
ScreenDC := GetDC(0);
OldX := X;
OldY := Y;
OldLeft := X;
OldTop := Y;
MoveRect := BoundsRect;
DrawFocusRect(ScreenDC,MoveRect);
Moving := True;
end;
end;

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Moving then begin
DrawFocusRect(ScreenDC,MoveRect);
OldX := X;
OldY := Y;
MoveRect := Rect(Left+OldX-OldLeft,Top+OldY-OldTop,
Left+Width+OldX-OldLeft,Top+Height+OldY-OldTop);
DrawFocusRect(ScreenDC,MoveRect);
end;
end;

procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
ReleaseCapture;
DrawFocusRect(ScreenDC,MoveRect);
Left := Left+X-OldLeft;
Top := Top+Y-OldTop;
ReleaseDC(0,ScreenDC);
Moving := False;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
TitleHeight,
BorderWidth,
BorderHeight : Integer;
begin
TitleHeight := GetSystemMetrics(SM_CYCAPTION);
BorderWidth := GetSystemMetrics(SM_CXBORDER)+GetSystemMetrics(SM_CXFRAME)-1;
BorderHeight := GetSystemMetrics(SM_CYBORDER)+GetSystemMetrics(SM_CYFRAME)-2;
if BorderStyle = bsNone then begin
BorderStyle := bsSizeable;
Top := Top-TitleHeight-BorderHeight;
Height := Height+TitleHeight+2*BorderHeight;
Left := Left-BorderWidth;
Width := Width+2*BorderWidth;
end
else begin
BorderStyle := bsNone;
Top := Top+TitleHeight+BorderHeight;
Height := Height-TitleHeight-2*BorderHeight;
Left := Left+BorderWidth;
Width := Width-2*BorderWidth;
end;
end;

end.

Коментарии

У меня есть один коментарий отностительно вышеприведенного кода: данная реализация сложней, чем она должна была быть. Все, что вы должны сделать - это обработать системное сообщение wm_NCHitTest. Я приведу здесь код, который я создал для Borland Tech Info, и который выполняет ту же функцию:

unit Dragmain;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;                    { вызвали наследованный дескриптор сообщения, }
if  M.Result = htClient then  { кликнув в области окна?                     }
M.Result := htCaption;      { если так, то мы заставили Windows думать,   }
{ что это область заголовка.                  }
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;

end.

[000100]


Как мне узнать, что форма "готовится" изменить размеры?

Ну примерно так:

{Перехватываем сообщение GetMinMaxInfo и устанавливаем минимальный размер окна,}
{используя декларированные константы}
procedure TForm1.WMGETMINMAXINFO( var message: TMessage );
var
mStruct: PMinMaxInfo;
begin
mStruct := PMinMaxInfo(message.lParam);
mStruct.ptMinTrackSize.x := HORIZONTALSIZE;
mStruct.ptMinTrackSize.y := VERTICALSIZE;

message.Result := 0;
end;

[000101]


Предотвращение изменения вертикальных размеров окна

Вы должны перехватывать сообщение WM_GETMINMAXINFO:

Поместите это в декларацию класса формы:

procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;

и в секции реализации:

procedure TMyForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
{ --------------------------------------------------------------------}
{ Поместите ваши величины вместо                                      }
{ MIN_WIDTH, MIN_HEIGHT, MAX_WIDTH, MAX_HEIGHT                        }
{                                                                     }
{ Для возможности только горизонтального изменение размера,           }
{ поместите значение свойства формы 'Height' в MIN_HEIGHT, MAX_HEIGHT }
{ --------------------------------------------------------------------}
Msg.MinMaxInfo^.ptMinTrackSize := Point(MIN_WIDTH, MIN_HEIGHT);
Msg.MinMaxInfo^.ptMaxTrackSize := Point(MAX_WIDTH, MAX_HEIGHT);
inherited
end;

И все заработает как надо.

[000102]


Предотвращение изменения размеров формы

Взято из статей Borland tech info

2958: Предотвращение изменения размеров формы

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

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

Используйте следующий модуль:

unit getminmax;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs;

type
TForm1 = class(TForm)

private
{ Private declarations }
procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup);
message WM_INITMENUPOPUP;
procedure WMNCHitTest(var Msg: TWMNCHitTest);
message WM_NCHitTest;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
inherited;
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.x:= form1.width;
ptMaxTrackSize.x:= form1.width;
ptMinTrackSize.y:= form1.height;
ptMaxTrackSize.y:= form1.height;
end;
end;

procedure TForm1.WMInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.SystemMenu then
EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_GRAYED)
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
with Msg do
if Result in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT,
HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then

Result:= HTNOWHERE
end;
end.  { Конец модуля}

Обработчик системного сообщения "WM_GetMinMaxInfo" в вышеприведенном коде использовался для установления минимального и максимального значения окна TrackSize, где этому значению были присвоены величины, задаваемые в период проектирования формы. На самом деле этого достаточно, чтобы форма не меняла размеров, но мы для примера добавили обработку еще двух сообщений, чтобы ваше приложение выглядело профессионально. Первым сообщением, обрабатываемым нами, было сообщение "WMInitMenuPopup", оно позволяло сделать недоступным пункт системного меню, касающегося возможности изменения размеров окна. Вторым сообщением было "WMNCHitTest", которое служило тем же целям - не создавать впечатления возможности изменения размера, а именно: запрет изменения вида курсора в момент нахождения его на границах окна.

Дополнение

По-моему, более целесообразно переписать само свойство окна, чем обработчик события WMNCHitTest- заодно и системное меню переписывается:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style:=Params.Style xor WS_SIZEBOX xor WS_MAXIMIZEBOX;
end;

С ув., Николай [000103]


Центрирование формы

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

Вариант 1

Я использую данный код при создании формы (событие FormCreate), но, может быть, стоит попробовать поместить его в обработчик события OnPaint, который вызывается при каждом изменении размера формы?

Form1.Left := (Screen.Width div 2) - (Form.Width  div 2);
Form1.Top := (Screen.Height div 2) - (Form.Height div 2);

Вариант 2

Если вы используете SetBounds, форма не будет перерисована дважды (один раз при изменении горизонтального размера, второй - вертикального, если это происходит одновременно). Попробуйте:

procedure CenterForm(AForm:TForm);
var ALeft,ATop:Integer;
begin
ALeft := (Screen.Width - AForm.Width) div 2;
ATop := (Screen.Height - AForm.Height) div 2;
AForm.SetBounds(ALeft, ATop, AForm.Widht, AForm.Height);
end;

Вариант 3

Procedure CenterForm(aForm: TForm);
Begin
aform.left := (screen.width - aform.width) shr 1;
aform.top := (screen.height - aform.height) shr 1;
End;

[000105]


Окно произвольной формы?

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

  1. Создайте новое приложение.
  2. Перепишите метод формы createparams как показано ниже.
  3. Разместите на форме какое-либо изображение и присвойте свойству transparent значение True.
  4. Установите "скоростную :-)" кнопку (SpeedButton) на форме и создайте метод, закрывающий приложение. (Форма получится круглой, поэтому системные кнопки и системное меню будет недоступно, они останутся за пределами контура формы.)
  5. Создайте метод, показанный ниже, отвечающий за обработку события OnCreate.
Надеюсь я помог вам.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Buttons;
type
TForm1 = class(TForm)
Image1: TImage;
SpeedButton1: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited createparams(params);
{Здесь убираем у формы заголовки и границы}
params.style:=params.style or ws_popup xor ws_dlgframe;
end;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
formrgn:hrgn;
begin
{очищаем форму}
form1.brush.style:=bsclear;
{делаем форму круглой}
GetWindowRgn(form1.Handle, formRgn);
DeleteObject(formRgn);
formrgn:=
CreateroundRectRgn(0,
0,form1.width,form1.width,form1.width,form1.width);
SetWindowRgn(form1.Handle, formrgn, TRUE);
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
form1.close;
end;
end.

[000106]


Добавление своих пунктов меню в системное меню окна

Прислал Aleksey msalex@tomcat.ru:

{Добавление своих пунктов меню в системное меню окна}
{поместите
const
My_MenuItem=$4000; (*константу можете по своему обозвать и дать ей другой номер, но есть какие-то номера, которые зарезервированы для виндузом для своих пунктов меню - не попадите на них*)
перед
var
Form1: TForm1;
ОБЯЗАТЕЛЬНО ПОМЕСТИТЕ В СЕКЦИЮ PRIVATE СТРОКУ
procedure HookSysCommand(var message : TwmSysCommand);message wm_SysCommand;
}

procedure TForm1.HookSysCommand(var message : TwmSysCommand);
begin
inherited;
case message.CmdType of
My_MenuItem : ShowMessage('Пункт активизирован');
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
SysMenu : THandle;
begin
SysMenu := GetSystemMenu(Handle, False);
AppendMenu(SysMenu, mf_SEPARATOR, 0, #0);
AppendMenu(SysMenu, mf_BYPOSITION, My_MenuItem, 'Новый пункт');
{appendmenu добавляет новый пункт в конец,
а для вставки своего пункта в другую порядковую позицию воспользуйтесь insertmenu
пример : InsertMenu(SMenu, 1, mf_BYPOSITION, My_MenuItem, 'Новый пункт');}
 end;
[000118]


Delphi 1

Скрытие дочерних MDI-форм

Может мне кто-нибудь помочь с проблемой скрытия MDIChild-форм в MDI приложении? В идеале я не хотел бы иметь минимизированную форму в родительской в виде характеристики по умолчанию, а хотел бы отображать в последней только иконку.

Это новое свойство Win 95. Так в этой операционной системе выглядят скрытые дочерние MDI-формы.

Тем не менее попытайтесь переписать WM_PAINT (может в вашем случае понадобиться WM_NCPAINT), проверьте IsIconized, и создайте скрытой форме красивую иконку.

- В настоящее время если я просто пытаюсь скрыть дочернюю форму, то получаю ошибку "Неверный метод в дочерней форме".

Тогда попробуйте ShowWindow(MdiChild1.Handle, SW_HIDE) и посмотрите что получится.

[000163]


Просто одно дочернее MDI-окно?

Решение 1

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

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

ChildIndex := 0
while (ChildIndex < frmMDIParent.ChildCount) and
(frmMDIParent.MDIChildren[ChildIndex].Name <> frmNewChild.Name) do
Inc(ChildIndex);
if ChildIndex = frmMDIParent.ChildCount then
{здесь создаем новое дочернее окно}
begin
Создаем...
если никакого исключения не произошло, показываем форму...
end
else
{дочерняя форма уже существует, поэтому просто помещаем ее поверх остальных}
frmMDIParent.MDIChildren[ChildIndex].BringToFront;

Решение 2

Создаем форму:

if Form1 <> nil then
begin
Form1 := TForm1.Create(Application);
Form1.Show;
end;

Обработчик события OnClose формы:

Action := caFree;
Form1 := nil;

[000164]


Придание MDI-формам большей "трехмерности"

В: Как мне заставить MDI-форму стать "более трехмерной" (наподобие Майкрософтовских программ)?

Данный ответ я почерпнул из раздела Tips & Tricks журнала The Delphi Magazine.

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;

[000165]


Заполнение изображением MDI-формы I

Привет всем! Кто-нибудь знает как поместить в MDI-форму изображение и заполнить им всю форму (tile)?

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)

Да. Это легкий вопрос..

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;

[000166]


Delphi 1

Заполнение изображением MDI-формы II

Несколько людей уже спрашивали, как залить фон главной 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 [000612]


Заполнение изображением MDI-формы III

Alexander N.Voronin пишет:

В разделе Заполнение изображением 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;

Пока.. [000893]


Удаление заголовка у дочерней MDI-формы

Решение 1

Мы смогли удалить область заголовка дочерней MDI-формы, сделав следующее:

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;

Решение 2

В дочерних MDI-формах выставление в свойстве BorderStyle флага bsNone НЕ убирает заголовок (это упоминается в файлах помощи). Попробуйте сделать так:

Procedure tMdiChildForm.CreateParams( var Params : tCreateParams ) ;
Begin
Inherited CreateParams( Params ) ;
Params.Style := Params.Style and (not WS_CAPTION) ;
End ;

[000167]


Проблема закрытия дочернего MDI-окна

Не пытайтесь разрушить форму из самой себя. Присвоение параметру action значения caFree в обработчике события формы OnClose заставит родительское окно самому уничтожить дочернюю форму.

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

Родительское MDI-окно должно иметь пункт меню для возможности закрытия активного в текущий момент дочернего окна. Вот примерный код, обрабатывающий нажатие данного пункта меню:

ActiveMDIChild.Close;

Попробуйте следующее:

procedure TFrmServers.FormClose(Sender:TObject; var
Action:TCloseAction);
begin
Action := caFree;
end;

procedure TFrmServers.FormDestroy
begin
Table1.Close;
end;

procedure TFrmServers.FormCloseQuery
begin
if table1.state in [dsEdit,dsInsert] then
begin
// предупреждаем пользователя о возможной потере редактируемых
// данных и при нажатии на ОК закрываем окно
if not UserSaysOk then CanClose := False;
end;
end;

[000169]


Фон 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.

[000170]


Минимизирование формы при запуске

Мне необходимо при запуске приложения спрятать главную форму, но, к сожалению, это не работает. После того, как я установил в главной форме свойство WindowState в wsMinimized и запустил ее, форма свернулась на рабочем столе Win95 вместо положенной панели задач.

Кто-нибудь знает как решить эту проблему?

Была одна статья по этому поводу в Delphi Magazine, Issue 19, март 1997, которая объясняла эту проблему.
Вот мой переработанный вариант обхода ошибки:

unit Foobar;

interface

type
TfrmFoobar = class(TForm);
procedure DoRestore(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

implementation

procedure TfrmUVChannel.FormCreate(Sender: TObject);
begin
//Устанавливаем временный обработчик события восстановления формы приложения
Application.OnRestore := DoRestore;
Application.Minimize;
end;

procedure TfrmFoobar.DoRestore(Sender: TObject);
begin
Application.ShowMainForm := True;
//Восстанавливаем приложение
Perform(wm_SysCommand, sc_Restore, 0);
//Гарантируем правильную перерисовку всех компонентов
Show;
//Убираем временного обработчика события чтобы не вызывался в будущем
Application.OnRestore := nil;
end;

initialization
//Здесь прячем минимизированную главную форму
Application.ShowMainForm := False;

end.

[000271]


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

Я пытаюсь создать приложение, помещающее во время запуска иконку в системную область панели задач 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;
[000274]


ПОМОГИТЕ !! STAY-ON-TOP !!!

Мне необходимо поместить Delphi-форму ДЕЙСТВИТЕЛЬНО поверх других приложений, не просто поверх всех форм приложения (что просто), а постоянно, даже если я использую, к примеру, EXCEL.

Попробуй использовать Windows API функцию SetWindowPos(). Примерно так...

with MyForm do
SetWindowPos(Handle,
HWND_TOPMOST,
Left,
Top,
Width,
Height,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

Возможно вам понадобиться вызывать данную функцию в обработчиках события OnShow(), OnDeactivate(), и OnActivate() вашей формы.

Nomadic дополняет:

В том случае, если приложение не активно (not foreground), твоя формочка благополучно скроется под другими приложениями :(.

Лечится вызовом 2-х функций в OnShow:

SetForegroundWindow(Form1.Handle); SetWindowPos(Form1.Handle,HWND_TOPMOST,0,0,0,0,SWP_NOMOVE+SWP_NOSIZE)
[000275]


Обработка запроса на максимальное раскрытие окна

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

Вам необходимо обработать из вашей формы сообщение WM_GETMINMAXINFO.

Например, добавьте следующее объявление в защищенную (protected) секцию вашей формы (interface):

procedure _WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO );  message wm_GetMinMaxInfo;

и создайте обработчик этого сообщения следующим образом (TForm1, естественно, имя вашей формы):

procedure TForm1._WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO );
begin
// устанавливаем позицию и размер вашей формы при ее максимальном раскрытии:
with mmInfo.minmaxinfo^ do
begin
ptmaxposition.x := Screen.Width div 4;
ptmaxposition.y := Screen.Height div 4;

ptmaxsize.x     := Screen.Width div 2;
ptmaxsize.y     := Screen.Height div 2;
end;
end;
[000277]


Сохранение размеров, позиции и состояния окна

Приведу код WindowRestorer - восстановителя размера и состояния окна.

ОПИСАНИЕ: Вы наверное замечали, что профессионально написанные программы "запоминают" состояние и позицию окон с момента их последнего показа? А большинство RAD-приложений это игнорируют? Вы можете исправить эту ошибку, взяв на вооружение этот модуль. Он позволяет сохранять позицию, размер и состояние окна, поэтому пользователь, открыв его вновь, увидит его в том же состоянии, в котором он видел его в последний раз.

ИСПОЛЬЗОВАНИЕ: Поместите WINRSTOR в список используемых модулей главной или любой другой формы, состояние, размер и позицию которой вы хотите сохранить. (Если вы сэкономить время и для восстановления дочерних форм использовать WinSaveChildren и WinRestoreChildren из главной формы, вы должны объявить этот модуль только в главной форме.)

В MainForm.Create, инициализируйте глобальный объект WinRestorer следующим образом (он должен предварительно быть объявлен, но еще не инициализирован):

GlobalWinRestorer := TWinRestorer.create( Application, TRUE, WHATSAVE_ALL);

Или так:

GlobalWinRestorer := TWinRestorer.create( Application, TRUE, [location, size, state]);

Затем в MainForm.Destroy вы должны разрушить глобальный объект WinRestorer следующим образом:

GlobalWinRestorer.free;

Хорошее место для сохранения статуса формы - в обработчике события queryclose или в специально созданной кнопке или пункте меню. Я обычно создаю этот пункт в меню "Файл" с именем '&Сохранение рабочей области' и обрабатываю следующим образом:

GlobalWinRestorer.SaveChildren(Self, [default]);

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

GlobalWinRestorer.SaveWin(Self, [WHATSAVE_ALL]);

Восстановить состояние дочерних форм можно следующим образом:

GlobalWinRestorer.RestoreWin(Self, [default]);

Я же переместил данный код в обработчик события show моей главной формы:

GlobalWinRestorer.RestoreWin(Self, [default]);
GlobalWinRestorer.RestoreChildren(Self, [default]);

Подсказки: Если вы установили TForm.Position в poScreenCenter или что-то подобное, данный модуль вам не поможет. poDesigned кажется, работает как положено. Можно добавить обработку исключения, если вы пытаетесь установить верхнюю или левую позицию при значении формы poScreenCentere, но при этом вы должны быть осторожными при использовании WinRestoreChildren. Я не проверял это со значениями координат (позиции) и оставил это на усмотрение разработчиков.

unit WinRstor;

INTERFACE

USES SysUtils, Forms;

TYPE {=============================================================}

{------------------------------------------------------------------
Восстановитель окон классовых объектов и связанных типов.
-------------------------------------------------------------------}
 EWinRestorer = class( Exception);
TWhatSave = (default, size, location, state);
STWhatSave = set of TWhatSave;
TWinRestorer = class(TObject)
protected
mIniFile: string;
mIniSect: string[80];
mIsInitialized: boolean;
mDefaultWhat: STWhatSave;
public
constructor Create( TheApp: TApplication;

LocalDir: boolean; DefaultWhatSave: STWhatSave);
{Если localDir = true, каталог ini = каталогу приложения. Else, ini dir is the windows dir.}
procedure SaveWin(TheForm: TForm; What: STWhatSave);
procedure SaveChildren(TheMDIForm: TForm; What: STWhatSave);
procedure RestoreWin( TheForm: TForm; What: STWhatSave);
procedure RestoreChildren(TheMDIForm: TForm; What: STWhatSave);
property IniFileName: string  read mIniFile;
end;

CONST
WHATSAVE_ALL = [size, location, state];

VAR
GlobalWinRestorer: TWinRestorer;

IMPLEMENTATION

Uses IniFiles;

constructor TWinRestorer.create;
var fname, path: string[100];
begin
inherited create;
{Получаем имя ini-файла}
if default in DefaultWhatSave then
raise EWinRestorer.create(
'Попытка инициализации параметров с позицией окна по умолчанию ' +
' с установленным элементом [default]. ' +
'Параметры по умолчанию могут содержать только установленные элементы - [size, location, state]. ')
else mDefaultWhat := DefaultWhatSave;

fname := ChangeFileExt( ExtractFileName( TheApp.exeName), '.INI');
if LocalDir then begin {вычисляем путь и добавляем к нему имя файла}
path := ExtractFilePath(TheApp.exeName);
if path[length(path)] <> '\' then
path := path + '\';
fname := path + fname;
end;
{заполняем поля объекта}
mIniFile := fname;
mIniSect := 'WindowsRestorer';
{Для культуры напишем некоторое примечание в секцию с именем [WinRestorer Notes]}
end;

procedure TWinRestorer.RestoreWin;

var FormNm, SectionNm: string[80];   ini: TIniFile;
n,l,t,w,h: integer; {Left, Top Width, Height}
begin
ini := TIniFile.create( mIniFile);
TRY
SectionNm := mIniSect;
FormNm := TheForm.classname;
if default in What then What := mDefaultWhat;
{При необходимости обновляем состояние окна}
if state in What then
n := ini.ReadInteger( SectionNm, FormNm + '_WindowState', 0);
case  n of
1:   TheForm.WindowState := wsMinimized;
2:  TheForm.WindowState := wsNormal;
3:   TheForm.WindowState := wsMaximized;
end;
{При необходимости обновляем размеры и позицию.}
with TheForm do begin l:=left; t:=top; h:=height; w:=width; end; {Сохраняем текущие значения.}
if size in What then begin
w := ini.ReadInteger( SectionNm, FormNm + '_Width', w);
h := ini.ReadInteger( SectionNm, FormNm + '_Height', h);
end;
if location in What then begin
t := ini.ReadInteger( SectionNm, FormNm + '_Top', t);
l := ini.ReadInteger( SectionNm, FormNm + '_Left', l);
end;
TheForm.SetBounds(l,t,w,h);
FINALLY
ini.free;
END;
end;

procedure TWinRestorer.RestoreChildren;
var i: integer;
begin
if TheMDIForm.formstyle <> fsMDIForm then
raise EWinRestorer.create('Попытка сохранения размеров дочернего окна для не-MDI окна родителя.')
else
for i := 0 to TheMDIForm.MDIChildCount - 1 do
RestoreWin( TheMDIForm.MDIChildren[i], what);
end;

procedure TWinRestorer.SaveWin;
var FormNm, SectionNm: string[80];   w : STWhatsave; ini: TIniFile;

begin
ini := TIniFile.create( mIniFile);
TRY
SectionNm := mIniSect;
FormNm := TheForm.ClassName;
if default in What then w := mDefaultWhat else w := mDefaultWhat;
if size in w then begin
ini.WriteInteger( SectionNm, FormNm + '_Width', TheForm.Width);
ini.WriteInteger( SectionNm, FormNm + '_Height', TheForm.Height);
end;
if location in w then begin
ini.WriteInteger( SectionNm, FormNm + '_Top', TheForm.Top);
ini.WriteInteger( SectionNm, FormNm + '_Left', TheForm.Left);
end;
if state in w then
case TheForm.WindowState of
wsMinimized:   ini.WriteInteger( SectionNm, FormNm + '_WindowState', 1);
wsNormal:      ini.WriteInteger( SectionNm, FormNm + '_WindowState', 2);
wsMaximized:   ini.WriteInteger( SectionNm, FormNm + '_WindowState', 3);
end;
FINALLY
ini.free;
END;
end;

procedure TWinRestorer.SaveChildren;
var i: integer;
begin
if TheMDIForm.formstyle <> fsMDIForm then
raise EWinRestorer.create('Попытка восстановления размеров дочернего окна для не-MDI окна родителя.')
else
for i := 0 to TheMDIForm.MDIChildCount - 1 do
SaveWin( TheMDIForm.MDIChildren[i], what);
end;

INITIALIZATION
END.

{ Данный код был найден в файлах помощи Ллойда (Lloyd)! } [000283]


Delphi 1

Как сделать окно системно-модальным?

SetSystemModalWindow(Form1.handle);

[000286]


Процедура автоматического масштабирования

Эта подпрограмма сделает жизнь программиста намного легче. Она делает так, чтобы ваша программа корректно масштабировалась при ЛЮБОМ разрешении экрана. Обратите внимание на число 640. Дело в том, что я разрабатываю свои приложения при разрешении 640x480. Вы можете настроить подпрограмму на ваше экранное разрешение при разработке программ и больше не беспокоиться о всевозможных низких и больших разрешений ваших пользователей. Разместите в обработчике события формы (которую вы хотите автомасштабировать) OnCreate следующую строку:

AdjustResolution(Self);

{ AdjustResolution ******************************************************* }
{ Данная процедура масштабирует все дочерние формы данной формы для        }
{ соответствия текущему разрешению                                         }
{ ************************************************************************ }
 procedure AdjustResolution(oForm:TForm);
var
iPercentage:integer;
begin
if Screen.Width > 640 then
begin
iPercentage:=Round(((Screen.Width-640)/640)*100)+100;
oForm.ScaleBy(iPercentage,100);
end;
end;

[000299]


Круглый логотип при запуске приложения

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

Без пробем! Код позволяет вывести окно-кольцо с полукруглой областью заголовка и сквозь дырку в форме можно увидеть и щелкнуть мышкой на других приложениях! Создайте новый проект и сохраните главный модуль с именем RGNU.PAS. Используйте следующий код:

unit rgnu;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, Menus;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
rTitleBar : THandle;
Center    : TPoint;
CapY      : Integer;
Circum    : Double;
SB1       : TSpeedButton;
RL, RR    : Double;
procedure TitleBar(Act : Boolean);
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);
message WM_NCACTIVATE;
procedure WMSetText(var Msg: TWMSetText);
message WM_SETTEXT;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

CONST
TitlColors : ARRAY[Boolean] OF TColor =
(clInactiveCaption, clActiveCaption);
TxtColors : ARRAY[Boolean] OF TColor =
(clInactiveCaptionText, clCaptionText);

procedure TForm1.FormCreate(Sender: TObject);
VAR
rTemp, rTemp2    : THandle;
Vertices : ARRAY[0..2] OF TPoint;
X, Y     : INteger;
begin
Caption := 'ОООО! Пончики!';
BorderStyle := bsNone; {требуется}
IF Width > Height THEN Width := Height
ELSE Height := Width;  {труднее вычислить если width <> height}
Center := Point(Width DIV 2, Height DIV 2);
CapY := GetSystemMetrics(SM_CYCAPTION)+8;
rTemp := CreateEllipticRgn(0, 0, Width, Height);
rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4),
3*(Width DIV 4), 3*(Height DIV 4));
CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
SetWindowRgn(Handle, rTemp, True);
DeleteObject(rTemp2);
rTitleBar  := CreateEllipticRgn(4, 4, Width-4, Height-4);
rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
Vertices[0] := Point(0,0);
Vertices[1] := Point(Width, 0);
Vertices[2] := Point(Width DIV 2, Height DIV 2);
rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
DeleteObject(rTemp);
RL := ArcTan(Width / Height);
RR := -RL + (22 / Center.X);
X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR));
Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR));
SB1 := TSpeedButton.Create(Self);
WITH SB1 DO
BEGIN
Parent     := Self;
Left       := X;
Top        := Y;
Width      := 14;
Height     := 14;
OnClick    := Button1Click;
Caption    := 'X';
Font.Style := [fsBold];
END;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
End;

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
Inherited;
WITH Msg DO
WITH ScreenToClient(Point(XPos,YPos)) DO
IF PtInRegion(rTitleBar, X, Y) AND
(NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN
Result := htCaption;
end;

procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
Inherited;
TitleBar(Msg.Active);
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
Inherited;
TitleBar(Active);
end;

procedure TForm1.TitleBar(Act: Boolean);
VAR
TF      : TLogFont;
R       : Double;
N, X, Y : Integer;
begin
IF Center.X = 0 THEN Exit;
WITH Canvas DO
begin
Brush.Style := bsSolid;
Brush.Color := TitlColors[Act];
PaintRgn(Handle, rTitleBar);
R  := RL;
Brush.Color := TitlColors[Act];
Font.Name := 'Arial';
Font.Size := 12;
Font.Color := TxtColors[Act];
Font.Style := [fsBold];
GetObject(Font.Handle, SizeOf(TLogFont), @TF);
FOR N := 1 TO Length(Caption) DO
BEGIN
X := Center.X-Round((Center.X-6)*Sin(R));
Y := Center.Y-Round((Center.Y-6)*Cos(R));
TF.lfEscapement := Round(R * 1800 / pi);
Font.Handle := CreateFontIndirect(TF);
TextOut(X, Y, Caption[N]);
R := R - (((TextWidth(Caption[N]))+2) / Center.X);
IF R < RR THEN Break;
END;
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := clWindowText;
Font.Style := [];
end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
WITH Canvas DO
BEGIN
Pen.Color := clBlack;
Brush.Style := bsClear;
Pen.Width := 1;
Pen.Color := clWhite;
Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0);
Pen.Color := clBlack;
Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
Arc((Width DIV 4)-1, (Height DIV 4)-1,
3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height);
TitleBar(Active);
END;
end;

end.

[000317]


Delphi 1

Иконка свернутого окна

Когда вы сворачиваете основную форму, иконка, которую вы наблюдаете, *НЕ ПРИНАДЛЕЖИТ* основной форме. Все попытки рисования на иконке потерпят неудачу, поскольку она принадлежит объекту application, а не форме.

File Manager при ситуации перетаскивания файлов (drag/drop) классно работает когда форма не свернута, но и он терпит неудачу, когда форма свернута, поскольку иконка НЕ является окном и не может зарегистрировать себя для сообщений drag/drop. Это проблема - как свернуть форму, т.к. щелкая по соответствующей системой кнопке, WindowState не принимает значения wsMinimized!

Обходной путь:

procedure TForm1.SysMen(var msg:TMessage);
begin
if msg.wParam = SC_MINIMIZE then begin
{сворачиваем форму}
WindowState := wsMinimized;
else
Inherited;
end;

[000341]


Одной строкой

Размер/позиция MDI-окна

Для того, чтобы управлять размером MDI-окна при запуске (дочерним или родительским), вам необходимо перекрыть метод CreateParams и присвоить свойствам Params.X, Params.Y, Params.Width и Params.Height необходимые значения.

Путь, при котором данные величины устанавливаются в событиях OnCreate MDI-форм никаких результатов не дает. [000342]


Окно без заголовка

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

Добавьте объявление процедуры

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;

Установите BorderStyle в bsSizeable. [000353]


Текущая позиция окна

Текущую позицию можно получить от холста, используя Windows API функцию GetCurrentPosition:

CurrentX := LoWord( GetCurrentPosition( Canvas.Handle ) ) ;
CurrentY := HiWord( GetCurrentPosition( Canvas.Handle ) ) ;

Mike Scott [000354]


Режимы разрешения для формы

Я сделал довольно полный набор тестов, результаты которого показаны ниже:

                               режим показа формы
 режим создания формы      -------------------------
 --------------------      640S      1024S     1024L
        640S,s              OK        OK        B
        640S,u              OK        OK        C
        1024S,s             OK        OK        B
        1024S,u             OK        OK        C
        1024L,s             A         A         OK
        1024L,u             OK        OK        OK

расшифровка:

 640  -> 640x480x256
 1024 -> 1024x768x256
 S/L  -> маленькие/большие шрифты
 s/u  -> Scaled := True/False

 OK: вид выводимой формы такой же, как и во время ее
     разработки
 A:  форма увеличивается относительно управляющих координат
 B:  форма сокращается относительно управляющих координат
 C:  форма и элементы управления слишком малы для текста

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

-Steve [000356]


Delphi 1

Маленькая область заголовка

Вам необходима небольшая область заголовка подобно той, которую использует Microsoft для управления палитры в VB, правильно? Около 1/3 от высоты нормальной области заголовка, без текста и без блока системных кнопок? Хорошо, я могу дать вам небольшой пример.

  1. Создайте вторичную форму и установите BorderStyle в bsSingle
  2. Разместите на форме компонент Label, удалите значение свойства Caption, установите Color в clBlue и Align в alTop. Задайте высоту компонента такую, какую высоту заголовка вы хотите
  3. Добавьте следующие два метода к вашей форме:

    PROCEDURE TForm2.CreateParams(VAR Params: TCreateParams);
    BEGIN
    Inherited CreateParams(Params);
    WITH Params DO
    Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
    END;

    PROCEDURE TForm2.wmNCHitTest(VAR Msg: TWMNCHitTest);
    BEGIN
    Inherited;
    WITH Msg DO
    IF YPos-Top <= Label2.Height THEN
    Result := HTCAPTION;
    END;

  4. Объявите эти функции в секции private вашего модуля:

    PROCEDURE CreateParams(VAR Params: TCreateParams); override;
    PROCEDURE wmNCHitTest(VAR Msg: TWMNCHitTest);
    message WM_NCHITTEST;

    Установите свойство вторичной формы Visible в True. Теперь у вас есть плавающее окно с мальнокой областью заголовка. Для создания также "небольшого" системного меню, НАРИСУЙТЕ его на форме и в ответ на событие WM_NCHITTEST установите Result в HTSYSMENU, если мышь в пределах области заголовка.

    - Neil [000387]


Delphi 1

Плавающая палитра

На самоме деле для создания плавающей (floating) палитры вы можете использовать вышу форму. Хитрость заключается в том, чтобы убедиться, что окно палитры всегда появляется на "переднем плане" основного окна, а не сверху всех других окон. Этот эффект может быть достигнут перекрытием метода CreateParams вашей формы. Для примера,

procedure TForm2.CreateParams( var Params: TCreateParams );
begin
inherited CreateParams( Params );
with Params do
begin
Style := Style or ws_Overlapped;
WndParent := Form1.Handle;
end;
end;

[000397]


"Трехмерные" формы с изменяющимися размерами

Попробуйте нижеприведенные обработчики событий WMNCPaint и WMNCHitTest.

При этом форма должна иметь свойство BorderStyle равным Sizeable, так как код использует область границ для создания 3D эффекта и предоставляет пользователю возможность изменения размера формы.

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

procedure TForm1.WMNCPaint (var Msg: TWMNCPaint);
var
DC      : HDC;
Frame_H : Integer;
Frame_W : Integer;
Menu_H  : Integer;
Caption_H : Integer;
Frame   : TRect;
Extra   : Integer;
Canvas  : TCanvas;
begin
{ Задаем значения некоторым параметрам окна }
Frame_W   := GetSystemMetrics(SM_CXFRAME);
Frame_H   := GetSystemMetrics(SM_CYFRAME);
if ( Menu <> nil ) then Menu_H := GetSystemMetrics(SM_CYMENU)
else Menu_H := -1;
Caption_H := GetSystemMetrics(SM_CYCAPTION);
GetWindowRect(Handle, Frame);
Frame.Right  := Frame.Right - Frame.Left - 1;
Frame.Left   := 0;
Frame.Bottom := Frame.Bottom - Frame.Top - 1;
Frame.Top    := 0;
{ Позволяем нарисовать стандартные границы формы }
inherited;
{ Перерисовываем область границ в 3-D стиле }
DC     := GetWindowDC(Handle);
Canvas := TCanvas.Create;
try
with Canvas do begin
Handle := DC;
{ Левая и верхняя граница }
Pen.Color := clBtnShadow;
PolyLine([Point(Frame.Left, Frame.Bottom),Point(Frame.Left, Frame.Top),Point(Frame.Right,Frame.Top)]);
{ Правая и нижняя граница }
Pen.Color := clWindowFrame;
PolyLine([ Point(Frame.Left, Frame.Bottom),
Point(Frame.Right, Frame.Bottom),
Point(Frame.Right, Frame.Top - 1)]);
{ Левая и правая граница, 1 пиксел скраю }
Pen.Color := clBtnHighlight;
PolyLine([ Point(Frame.Left + 1, Frame.Bottom - 1),
Point(Frame.Left + 1, Frame.Top + 1),
Point(Frame.Right - 1, Frame.Top + 1)]);
{ Правая и нижняя граница, 1 пиксел скраю }
Pen.Color := clBtnFace;
PolyLine([ Point(Frame.Left + 1, Frame.Bottom - 1),
Point(Frame.Right - 1, Frame.Bottom - 1),
Point(Frame.Right - 1, Frame.Top)]);
{ Разность области изменяемых границ }
for Extra := 2 to (GetSystemMetrics(SM_CXFRAME) - 1) do begin
Brush.Color := clBtnFace;
FrameRect(Rect(Extra, Extra, Frame.Right - Extra + 1, Frame.Bottom - Extra + 1));
end;
{ Левая и верхняя граница области заголовка }
Pen.Color := clBtnShadow;
PolyLine([ Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame_W - 1, Frame_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H - 1) ]);
{ Левая и верхняя граница области заголовка }
Pen.Color := clBtnHighlight;
PolyLine([ Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H - 1) ]);
end;
finally
Canvas.Free;
ReleaseDC(Handle, DC);
end; { try-finally }
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var
HitCode : LongInt;
begin
inherited;
HitCode := Msg.Result;
if ( (HitCode = HTLEFT)     or (HitCode = HTRIGHT)      or
(HitCode = HTTOP)      or (HitCode = HTBOTTOM)     or
(HitCode = HTTOPLEFT)  or (HitCode = HTBOTTOMLEFT) or
(HitCode = HTTOPRIGHT) or (HitCode = HTBOTTOMRIGHT) ) then begin
HitCode := HTNOWHERE;
end;

Msg.Result := HitCode;
end;
[000415]


Delphi 1

Масштабирование окна I

implementation
const
ScreenWidth: Integer = 800; {Я разрабатывал свою форму в режиме 800x600.}
ScreenHeight: Integer = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
x, y: LongInt; {Тип Integer не достаточно большой для наших значений.}
begin
form1.scaled := true;
x := getSystemMetrics(SM_CXSCREEN);
y := getSystemMetrics(SM_CYSCREEN);
if (x <> ScreenHeight) or (y <> ScreenWidth) then
begin
form1.height := form1.height * x DIV ScreenWidth;
form1.width := form1.width * y DIV ScreenHeight;
end;
if x <> ScreenWidth then scaleBy(x, ScreenWidth);
end;

Спасибо Andrey Kozlov за ценные замечания.

Дополнение

Файл DELSEQ07.FAQ содержит код примера отображения форм в различных разрешениях. К сожалению, он не учитывал ширину границы окна. Я публикую изменение, масштабирующее компоненты вне зависимости от разрешения экрана и ширины границ окон. Включите нижеследующий модуль в секцию uses каждого модуля и вызывайте ScaleForm в обработчике формы OnCreate, передавая в качестве параметра имя формы. Я надеюсь что помог тем, кто столкнулся с данной проблемой.

unit scale;

interface

uses
Forms, WinTypes, WinProcs, SysUtils;

procedure ScaleForm(Sender: TObject);

implementation

procedure ScaleForm(Sender: TObject);

const
{измените это так, чтобы это соответствовало режиму разрешения во время разработки}
DesignScrY:   LongInt = 480;
DesignScrX:   LongInt = 640;
DesignBorder: LongInt = 4;  {значение в Панели Управления + 1}

var
SystemScrY:   LongInt;
SystemScrX:   LongInt;
SystemBorder: LongInt;
OldHeight:    LongInt;
OldWidth:     LongInt;

begin
SystemScrY := GetSystemMetrics(SM_CYSCREEN);
SystemScrX := GetSystemMetrics(SM_CXSCREEN);
SystemBorder := GetSystemMetrics(SM_CYFRAME);
with Sender as TForm do
begin
Scaled := True;
AutoScroll := False;
Top := Top * SystemScrX div DesignScrX;
Left := Left * SystemScrX div DesignScrX;
OldHeight := Height + (DesignBorder - SystemBorder) * 2;
OldWidth := Width + (DesignBorder - SystemBorder) * 2;
ScaleBy((OldWidth * SystemScrX div DesignScrX - SystemBorder * 2),
(OldWidth - DesignBorder * 2));
{
Для форм не имеющих границ измените предшествующие три строки следующим способом:
OldHeight := Height;
OldWidth  := Width;
ScaleBy(SystemScrX, DesignScrX);
}
Height := OldHeight * SystemScrY div DesignScrY;
Width := OldWidth  * SystemScrX div DesignScrX;
end;
end;

begin
end.

[000433]


Delphi 1

Масштабирование окна II

Вывод формы с различными разрешениями экрана.

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

implementation
const
ScreenWidth: LongInt = 800; {Я разрабатывал мою форму в режиме 800x600.}
ScreenHeight: LongInt = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
scaled := true;
if (screen.width <> ScreenWidth) then
begin
height := longint(height) * longint(screen.height) div ScreenHeight;
width := longint(width) * longint(screen.width) div ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end;
end;

Затем, вероятно, вы захотите иметь нечто, проверяющее размер шрифтов, OK. Прежде, чем вы измените размер шрифта, вам необходимо убедиться, что объект имеет свойство font. Это может быть сделано следующим образом:

uses typinfo;

var
i: integer;
begin
for i := componentCount - 1 downtto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') <> nil  then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;

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

  • Заранее, в самом начале этапа разработки, решите для себя - собираетесь ли вы разрешать масштабировать форму или нет. Преимущество запрета масштабирования в том, что вам ничего не нужно менять во время выполнения приложения. Недостаток запрета масштабирования - во время выполнения приложения никаких изменений не происходит (ваша форма может быть слишком малой или слишком большой для работы в некоторых режимах при отсутствии масштабирования).
  • Если вы НЕ собираетесь масштабировать форму, установите свойство Scaled в False.
  • В противном случае, установите свойство формы Scaled в True.
  • Установите AutoScroll в False. AutoScroll = True означает 'не изменять размер окна формы во время выполнения приложения', что приводит к "плохому виду" формы, если ее содержимое меняет размер.
  • Установите шрифты формы в масштабируемые TrueType-шрифты типа Arial. MS San Serif также подойдет в качестве альтернативы, только помните, это не TrueType, а bitmapped-шрифт. Только Arial может правильно изменять свою высоту с дискретностью 1 пиксел. Примечание: Если используемый шрифт не установлен на машине пользователя, Windows выбирает альтернативный шрифт из данной линейки (семьи) шрифтов. Размеры нового шрифта могут отличаться от размеров оригинального шрифта, что также может вызвать проблемы.
  • Установите свойство формы Position во что-нибудь другое, чем poDesigned. poDesigned всегда показывает форму в первозданном виде, и, если форма разрабатывалась в разрешении 1280x1024, то вы можете себе представить, что будет при разрешении 640x480?
  • Не "слепляйте" на форме элементы управления, оставляйте между ними, по крайней мере, 4 пикселя, в противном случае, при изменении месторасположения границы на 1 пиксель (это происходит при масштабировании), элементы управления наедут друг на друга.
  • Для однострочных компонентов Label, у которых свойство Aligned равно alLeft или alRight, установите AutoSize в True. В противном случае, установите AutoSize в False.
  • Убедитесь в том, что компоненты Label имеют достаточный запас по ширине (требуется, примерно, 25%) от длины текущего текста. (При переводе вашего приложения на другие языки вам необходимо примерно 30%-ный запас от текущей ширины текста). Если AutoSize - False, убедитесь, что ширины компонента Label достаточно для размещения реального текста. Если AutoSize - True, убедитесь, что на компоненту Label достаточно места (например, на форме) для размещения всего текста плюс небольшой запас для его роста при смене шрифтов.
  • В случае многострочного текста и компонентов Label с переносом слов, убедитесь, что в нижней части у вас имеется, по крайней мере, еще одна строчка. Она необходима вам для того, чтобы не допустить переполнения строки, если размер шрифта увеличивается при масштабировании. Не думайте, что, если вы используете большие шрифты и переполнения не возникает, то эта проблема снята - кто-нибудь может использовать шрифты с еще большим размером, чем у вас!
  • Будьте осторожными при открытии проекта в IDE с другим разрешением. Свойство формы PixelsPerInch будет изменено как только вы откроете форму, и сохранено в DFM-файле при сохранении проекта. Лучше всего запускать приложение отдельно от IDE, а редактировать его при одном разрешении. Редактируя формы при различных разрешениях и размерах шрифтов, вы инициируете проблему "дрейфа" компонентов по форме и изменения их размера.
  • Говоря о дрейфе компонент, не следует многократно масштабировать форму, как во время разработки, так и во время выполнения приложения. Каждое изменение размеров сопровождается ошибками округления, которые достаточно быстро накапливаются с тех пор, как координаты стали строго целочисленными. Поскольку при калькулировании новых размеров дробная часть отбрасывается, вновь пересчитанные размеры оказываются меньше, а координаты элементов управления северо-западнее. Если вы решили разрешить пользователю изменять масштабы форм, начинайте масштабирование с последней загруженной/созданной формы, этим вы уменьшите накапливаемые при масштабировании ошибки.
  • Старайтесь не изменять значение свойства формы PixelsPerInch.
  • В общих словах, нет необходимости разрабатывать формы для всех возможных режимов, перед окончательным релизом вашего приложения вы должны оценить поведение формы в пограничных режимах - 640x480 с маленькими и большими шрифтами, и при высоком разрешении и, также, с маленькими и большими шрифтами. Это должно быть частью ваших регулярных проверок на предмет системной совместимости, для ведения так называемой тестирующей контрольной таблицы.
  • Обратите пристальное внимание на "однострочные компоненты TMemo" - типа TDBLookupCombo. Системные многострочные редакторы всегда выводят только целые строки текста - если ширина элемента управления слишком мала для своего шрифта, то TMemo вообще ничего не показывает (TEdit показывает обрезанный текст). Размер таких компонентов лучше сделать на несколько пикселей больше, чем на несколько пикселей меньше, тем самым можно определеть наличие в компоненте оставшейся части текста.
  • Обратите внимание на то, что масштабирование во время проектирования и во время выполнения программы отличается коэффициентом и зависит от высоты шрифта, а не от экранного разрешения в пикселях. Помните также, что "начало" компонент будет изменяться в зависимости от масштаба формы, и для их "броуновского" движения также необходимо небольшое пространство.
[000626]


Delphi 1

Замена Form на FormIni

unit Formini;

{$IFDEF Production}
{$S-,R-,D-,L-,W-}
{$ENDIF}

{
TFormINI новая замена TForm, умеющая автоматически сохранять и восстанавливать
значения свойств Top, Left, Height, Width и WindowState
из программного INI-файла без какого-то либо программирования.

Код берет имя выполняемого файла из Application.EXEName и меняет
расширение на .INI.

В качестве имени секции при хранении величин в INI-файле,
TFormINI использует заголовок формы.

Просто замените все существующие объявления класса TForm на TFormINI,
и TFormINI позаботится обо всем остальном (в пределах функциональности).

Теперь ваши формы будут такие же, как и при их закрытии.

TMyForm = class(TForm) -> TMyForm = class(TFormINI)
}
interface

uses InIFiles, Forms, Controls, SysUtils, WinTypes, Classes;

type
TFormINI = class(TForm)
private
PrgINI: TIniFile;
FSection: String;
protected
procedure WriteInteger(Section, Ident: String; value: longint);
function ReadInteger(Section, Ident: String; Default: longint): longint;
public
constructor Create(AOwner: TComponent); override;
procedure CreateParams(var Params: TCreateParams); override;

procedure DoShow; override;
destructor Destroy; override;
end;

implementation

constructor TFormINI.Create(AOwner: TComponent);
var
INIFile: string;
begin
INIFile := ExtractFileName(Application.EXEName);
INIFile := ChangeFileExt(INIFile, '.INI');
PrgINI := TIniFile.Create(INIFile);
inherited Create(AOwner);
end;

procedure TFormINI.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
FSection := StrPas(Caption);
Y := ReadInteger('', 'Top', 0);
X := ReadInteger('', 'Left', 0);
Width := ReadInteger('', 'Width', Width);
Height := ReadInteger('', 'Height', Height);
end;
end;

procedure TFormINI.DoShow;
var
aWindowState: integer;
begin
aWindowState := ReadInteger('', 'WindowState', 0);
Case aWindowState of
0: WindowState := wsNormal;
1: WindowState := wsMinimized;
2: WindowState := wsMaximized;
end;
inherited DoShow;
end;

procedure TFormINI.WriteInteger(Section, Ident: String; value: longint);
begin
if Section = '' then
PrgINI.WriteInteger(FSection, Ident, value)
else
begin
PrgINI.WriteInteger(Section, Ident, value);
FSection := Section;
end;
end;

destructor TFormINI.Destroy;
begin
if WindowState = wsNormal then
begin
WriteInteger('', 'Top', Top);
WriteInteger('', 'Left', Left);
end;
WriteInteger('', 'Width', Width);
WriteInteger('', 'Height', Height);
Case WindowState of
wsNormal: WriteInteger('', 'WindowState', 0);
wsMinimized: WriteInteger('', 'WindowState', 1);
wsMaximized: WriteInteger('', 'WindowState', 2);
end;
PrgINI.Free;
inherited Destroy;
end;

function TFormINI.ReadInteger(Section, Ident: String; Default: longint): longint;
begin
if Section = '' then
Result := PrgINI.ReadInteger(FSection, Ident, Default)
else
begin
Result := PrgINI.ReadInteger(Section, Ident, Default);
FSection := Section;
end;
end;

end.

Nick Hodges
Monterey, CA [000449]


Одной строкой

Как сделать прозрачную форму

procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Style := bsClear;
Form1.BorderStyle := bsNone
end;

Прислал Alexander Vozny. [000460]


Показ/скрытие дочерних MDI-окон

...да, я понял: необходим гарантированный показ или скрытие MDI-окна. Гарантированно скрыть можно вызовом ShowWindow(theHandle, SW_HIDE), но в этом случае при показе *НЕ* используется ShowWindow. Вместо это сделайте так:

SetWindowPos(theHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE OR
SWP_NOSIZE OR SWP_SHOWWINDOW);

Далее я обнаружил, что дочерние окна не скрывались/показывались, *ЕСЛИ* для осуществления этих функций использовались оконные компоненты (например, кнопки). Для решения проблемы добавьте следующую строку после вызова SetWindowPos:

WinProcs.SetFocus(TheHandle);

*НЕ* используйте метод SetFocus; SetFocus здесь - Windows API функция.

- Neil

Дополнение

По моему,все-таки, вызов ShowWindow(theHandle, SW_HIDE)проще, короче и, по крайней мере, в Delphi5 нормально работает с оконными компонентами.

procedure TMainForm.Button1Click(Sender: TObject);
begin //кнопка для показа/скрытия дочернего MDI-окна
If ShowWindow(form1MDI.Handle, SW_HIDE)=False
then ShowWindow(form1MDI.Handle, SW_SHOW);
end;

С уважением Михаил Шпанер.
forensicmed@mail.ru [000497]


Delphi 1

Использование события OnHint во многих формах

Электронная справка Delphi и "Visual Component Library Reference" имеют пример обработчика события объекта TApplication OnHint. Пример показывает как панель может использоваться для отображения подсказок соответствующих компонентов. Так как пример назначает метод объекта Application OnHint в обработчике события формы OnCreate, то программа, имеющая более чем одну форму, будет иметь трудности при использовании данной технологии.

Перемещение назначения метода OnHint из обработчика формы OnCreate в обработчик OnActivate позволит другим формам приложения также манипулировать выводом подсказок.

Вот измененный текст кода, представленный в электронной справке и VCL Reference.

type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
Edit1: TEdit;
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
procedure DisplayHint(Sender: TObjject);
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;
[000535]


Delphi 1

Кнопка заголовка активного окна

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

procedure TForm1.WMNCPaint(VAR Msg: TWMNCPaint);
VAR R: TRect;
BEGIN
Inherited;
Canvas.Handle := GetWindowDC(Handle);
R := Bounds(GetSystemMetrics(SM_CXFRAME) +
GetSystemMetrics(SM_CXSIZE) + 1,
GetSystemMetrics(SM_CYFRAME),
GetSystemMetrics(SM_CXSIZE),
GetSystemMetrics(SM_CYSIZE));
WITH Canvas DO
BEGIN
Brush.Color := clRed;
Pen.Color := clLime;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
END;
ReleaseDC(Handle, Canvas.Handle);
END;
[000557]


Одной строкой

Форма постоянно сверху приложения?

Форма должна иметь нормальный стиль (normal style), необходимо лишь переписать процедуру CreateParams:

procedure TFloatingToolbar.CreateParams( var Params: TCreateParams );
begin
inherited CreateParams( Params );
with Params do
begin
Style := Style or ws_Overlapped;
WndParent := MainForm.Handle;
end;
end;
[000572]


Delphi 1

Невидимые формы в EXE и DLL

К примеру, требуется, чтобы в EXE- или в DLL-проекте отсутствовали какие-либо формы или компоненты, хотя и так большинство компонентов (windows UI-элементов управления) не имеют смысла вне формы.

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

Для примера, процесс создания компонента TDatabase в DLL или EXE "ручками" выглядит примерно таким образом:

procedure XYZ;
var
DB: TDatabase;
begin
DB := TDatabase.Create( nil);
{ теперь используем это }
DB.Alias := 'test';
DB.Active := true;
DB.DoSomething
DB.DosomethingElse
{ теперь освобождаем экземпляр TDatabase }
DB.Free
end;

Для не-визуальных компонентов форма, сама по себе, не имеет никакого значения. Поскольку TForm является дальным наследником TComponent, то она может быть владельцем других компонентов, тем не менее эта характеристика не добавляет функциональности расположенным на ней компонентам. Так какое преимущество существует у компонентов, расположенных на форме? Удобное, но небольшое: при разрушении формы (или компонента), предварительно автоматически освобождаются все компоненты, владельцем которых она является (ссылки на них содержатся во внутреннем списке).

Какое преимущество дает форма для не-визуальных компонентов (TDatabase, TTable и пр.) кроме их автоматического освобождения при освобождении формы? Никакого. Только то, что при использовании визуального конструирования все компоненты, располагаемые на форме, становятся принадлежащими этой форме и позволяют изменить их свойства по умолчанию.

Флаг видимости, как и ожидалось, работает и в dll, и в exe, тем не менее вы должны знать, что некоторые функции, например, Application.Run, устанавливают для главной формы visible := true. Вы не сможете это корректно обойти, поскольку эта форма является главной формой приложения, а для запуска приложения вы вызываете Application.Run.

Если вы хотите сделать главную форму невидимой, замените строку Application.Run следующей конструкцией:

repeat
Application.HandleMessage;
until Application.Terminated;
Application.Destroying;
Application.DestroyComponents;

Если вы все еще имеете проблемы с невидимыми формами в DLL, дайте мне знать как вы это делаете.

Успехов, James Thorpe
Borland Australia. [000596]


Delphi 1

Косвенный вызов формы

Передаем имя класса формы переменной с именем FormClassName:

MyForm := TFormClass(FindClass(FormClassName)).Create(Application);

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


Delphi 1

Показ формы без фокуса

ShowWindow(theWindowHandle, SW_SHOWNOACTIVE);

[000609]


Delphi 1

Создание синего экрана установки

Пример градиентной заливки:

procedure TForm1.FormPaint(Sender: TObject);
var
Row, Ht: Word ;
begin
Ht := (ClientHeight + 255) div 256 ;
for Row := 0 to 255 do
with Canvas do begin
Brush.Color := RGB(0, 0, Row) ;
FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht)) ;
end ;
end;

[000667]


Delphi 1

Универсальный создатель формы

Обратите внимание на методы FindClass/GetClass и RegisterClass. С помощью их вы можете эффективно перевести строку (имя класса формы) в тип класса этой формы, и затем выполнить такую команду:

MyForm := TForm(FindClass(SomeString)).Create(Self);

[000688]


Одной строкой

Создание формы переменного типа

Как насчет этого? (допустим что str содержит 'TForm2' и т.п.)?

procedure TForm1.Button1Click(Sender: TObject);
begin
with TFormClass(FindClass(str)).Create(Application) do try
ShowModal;
finally
Free;
end;
end;

initialization
RegisterClasses([TForm2,TForm3,TForm4]);
end.

- Mike Orriss (да, я сделал это сам <g>) [000816]


Delphi 1

Позиция дочерних MDI-окон

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

У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы 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) делает две вещи:

  1. выравнивает элементы управления (включая ваш проблемный StatusBar) и
  2. вновь позиционирует окно клиента относительно главной формы (оно ссылается на ClientHandle) после того, как элементы управления будут выравнены... что, впрочем, мы и хотели.
- Richard Cox [000831]


Показ окна без главной формы

Как сделать форму видимой без главной формы.

Как мне сделать так, чтобы видимой была только выбранная форма? (то есть без главной формы)

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

...
private {Это включается в объявления формы.}
{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams); override;
...

procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
Params.WndParent := GetDesktopWindow;
end;

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

[000835]


Изменение модального статуса формы

Вы не можете изменить статус формы с не-модального на модальный без ее закрытия и повторного открытия.

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

procedure TForm2.DataSource1StateChange(Sender: TObject);
var
ix: integer;
b: boolean;
begin
with (Sender as TDataSource).DataSet do b := (State = dsBrowse);
with Screen do
for ix := 0 to FormCount-1 do
if Forms[ix] <> ActiveForm then Forms[ix].Enabled := b;
end;

Примечание: вам также потребуется предотвращение закрытия формы, пока таблица находится в режиме редактирования (через обработчик события OnCloseQuery).

- Mike Orriss [000862]


Delphi 1

Восстановление размера окна

Существует ли какой-либо способ получения координат формы, которые она должна иметь при восстановлении с максимально распахнутого состояния?

Используйте API Функцию GetPlacement. Следующая выдержка из кода моего компонента TBag демонстрирует это:

procedure TBag.SetFormPlace(AName: string; AForm: TForm);
var
s: string[99];
Place : TWindowPlacement;
begin
Place.length :=SizeOf(TWindowPlacement);
if not GetWindowPlacement(AForm.Handle,@Place) then exit;
with Place do begin
s := IntToStr(Flags);
s := AppendS(s,ShowCmd);
s := AppendS(s,ptMinPosition.X);
s := AppendS(s,ptMinPosition.Y);
s := AppendS(s,ptMaxPosition.X);
s := AppendS(s,ptMaxPosition.Y);
s := AppendS(s,rcNormalPosition.Left);
s := AppendS(s,rcNormalPosition.Top);
s := AppendS(s,rcNormalPosition.Right);
s := AppendS(s,rcNormalPosition.Bottom);
end;
SetString(AName,s);
end;

- Mike Orriss [000876]


Динамическое создание формы

Я хочу следующее:
  • мой компонент должен "динамически" создавать форму.
  • я не хочу включать имя модуля создаваемой формы в список используемых модулей моей текущей формы!!!

Ок, но модуль, содержащий форму, должен включаться в ваш EXE-файл, после чего вы должны вызвать RegisterClass. Наилучшее место для размещения вызова - секция инициализации модуля, определяющего форму:

unit MyUnit;

interface

type
TMyForm = class(TForm)
...

implementation

...

initialization
RegisterClass(TMyForm);
end.

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

var
SomeForm: TForm;
FormClass: TFormClass;
...
FormClass := TFormClass(FindClass('TMyForm'));
SomeForm := FormClass.Create(Application);
...

-Steve Schafer [000889]


Создание фона на форме

Как заполнить фон моей формы повторяющимся изображением?

unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Bitmap: TBitmap;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;

procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do begin
X := 0;
while X < Width do begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;

end.

[000935]


Delphi 2

Форма Delphi на панели задач

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

type
TForm2 = class(TForm)
private
{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams);
override;
...
procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
WITH Params DO
ExStyle := ExStyle OR WS_EX_APPWINDOW;
end;

- Neil Rubenking

Nomadic дополняет:

Обратите внимание, что мы делаем override. Вы можете написать просто Inherited, без указания имени метода (если оно совпадает с именем данного) и аргуметов (в таком случае передаются в качестве аргументов исходные). Часто возникает противоположная по смыслу задача - убрать окна с панели задач (в случае, если они создаются в DLL). В таком случае используйте стиль WS_Ex_ToolWindow. [000972]


Канва от THandle (для метафайлов)

В: Мне необходимо нарисовать Windows-метафайл. Delphi непосредственно это не поддерживает, поэтому для создания нового метафайла я использую функции Windows API. При создании метафайла мне возвращается его THandle, являющийся дескриптором контекста устройства Windows (DC).

Как мне в Delphi использовать возвращаемый THandle для получения или создания канвы (Canvas) для рисования?

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

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
{ Создаем в памяти DC метафайла }
MetafileDC := CreateMetaFile(nil);
if Bool(MetafileDC) then
begin
{ Совмещаем верхний левый угол отображаемого прямоугольника с левым верхним углом
контекста устройства. Создаем границу шириной 10 логических единиц вокруг изображения. }
with FRect do SetWindowOrg(MetafileDC, Left - 10, Top - 10);
{ Устанавливаем размер изображения с бордюром, имеющим ширину 10 логических единиц. }
with FRect do SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
{ Задаем корректное содержание данному метафайлу. }
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;
{ Подготавливаем метафайл для показа в буфере обмена. }
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);
{ Передаем дескриптор в качестве результата выполнения функции. }
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.
[000112]


TMetafile - ошибка при работе с памятью

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

Я долго экспериментировал и пришел к выводу, что все эти ошибки возникают в случае, когда map mode (режим карты) использует не mm_Text. Я трассировал ошибку в TMetafile.SaveToClipboardFormat. Программа неверно использует значение по умолчанию TMetafileImage.FInch = 0. Я думаю что TMetafileImage должен иметь значение по умолчанию FInch = Screen.PixelsPerInch или программа, которая сохраняет его в буфере обмена, должна правильно использовать FInch = 0 (т.е. сделайте значение mm_Text). [000332]


Недокументированный TParser

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

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

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

  toEOF     = Char(0);
  toSymbol  = Char(1);
  toString  = Char(2);
  toInteger = Char(3);
  toFloat   = Char(4);
В зависимости от значения, для получения элемента вы вызываете соответствующий. Например, если Token = toString, то фактический элемент строки извлекается с помощью вызова TokenString. Если это toInteger, то вызывайте TokenInt и т.д.. Для получения следуюшего символа вызывайте NextToken, который возвратит его значение.

Я надеюсь, что при получении вашей копии Delphi вы найдете ответы на остальные ваши вопросы.

--- Mike Scott -- [000357]


Использование TParser

Вы просили пример кода использования TParser. Хорошо, вот несколько процедур для модуля Parser для создания документации Delphi-компонент напрямую из исходного кода.

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

{ TDelphiUnitParser }

function TDelphiUnitParser.CheckSectionBreak : Boolean ;

begin
with Parser do begin
Result := ( Token = toSymbol ) and
( Compare( 'Var' ) or
Compare( 'Const' ) or
Compare( 'Type' ) or
Compare( 'Implementation' ) or
Compare( 'Procedure' ) or
Compare( 'Function' ) ) ;
end ;
end ;

procedure TDelphiUnitParser.ParseParameterList ;

begin
with Parser do begin
{ пропускаем '(' }
NextToken ;
while Token <> ')' do NextToken ;
NextToken ;
end ;
end ;

procedure TDelphiUnitParser.ParseRecord ;

begin
with Parser do begin
{ пропускаем 'record' }
NextToken ;
while ( Token <> toSymbol ) or not Compare( 'End' ) do
begin
if Token = 'Record' then ParseRecord else NextToken ;
end ;
end ;
end ;

procedure TDelphiUnitParser.ParseDeclaration ;

begin
with Parser do begin
while Token <> ';' do begin
if Token = '(' then ParseParameterList else
if ( Token = toSymbol ) and Compare( 'Record' ) then
ParseRecord else
NextToken ;
end ;
end ;
end ;

procedure TDelphiUnitParser.ParseConst ;

var AString     : String ;
AStart      : PChar ;
EndOfConsts : Boolean ;

begin
with Parser do begin
NextToken ;
repeat
if Token <> toSymbol then ErrorStr( 'Неопознанный идентификатор' ) ;
AString := TokenString ;
AStart := FSourcePtr ;
NextToken ;
if not( Token in [ '=', ':' ] ) then ErrorStr( '''='' or '':''
ожидалось' ) ;
ParseDeclaration ;
FindToken( ';' ) ;
until CheckSectionBreak ;
end ;
end ;

--- Mike Scott --- [000435]


Delphi 1

Пример TParser

С интересом прочли ваш совет про TParser. Может вы смогли бы нам еще немного помочь советом? Нам необходимо вычислить математическое выражение с применением стандартных механизмов (приоритеты, порядок и т.д.). Это возможно с помощью TParser? Или придется все делать ручками?

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

...простой пример, который мы хотим парсировать:

(23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1

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

      Expr   ::= Term + Expr | Term - Expr | Term
      Term   ::= Factor * Term | Factor / Term | Factor
      Factor ::= + Item | - Item | Item
      Item   ::= ( Expr ) | Fn( Expr ) | Number
      Fn     ::= Sin | Cos
      Number ::= floating point literal number (плавающая точка литерала числа)
Далее идет модуль и форма, показывающие как это можно использовать. Вы должны скопировать текст формы в окно редактора Delphi и сохранить как DFM-файл. Мои расчеты вашего выражения привели к результату 130.086 - это правильно?

Примечание: TParser имеет ошибку в подпрограмме парсирования плавающего числа. Любое сочетание символов с символами '+' или '-' воспринимается как часть плавающего числа, поскольку 1e+3 корректное выражение. Естественно, это должно быть правильным только в совокупности с символом 'e'. Поэтому вы должны убедиться, что перед символами '+' и '-' имеется хотя бы один пробел, как показано в вашем выражении. Вы можете это исправить (если у вас есть исходный код VCL), редактируя функцию TParser.NextToken.

Скопируйте поочередно три приведенных ниже файла и вставьте их в окно редактора Delphi. Самый простой способ - закройте все открытые проекты и создайте новый модуль. Выделите весь текст, сгенерированный Delphi и вставьте текст модуля ExpParse. Сохраните его под именем ExpParse.pas. Затем создайте другой модуль, перенесите в него EvalForm.pas и также сохраните. Снова закройте файл и создайте новый модуль. Вставьте в него EvalForm.dfm и сохраните, выбрав меню "Save as" и отметив в списке тип файла DFM. Затем создайте новый проект, удалите форму, созданную по умолчанию и добавьте файл EvalForm.pas.

-----------------------ExpParse.pas----------------------------

unit ExpParse;

interface

uses Classes ;

{ Набор парсируемых элементов определяется как подмножество
выражений Delphi Object Pascal, подобно этому:

Expr   ::= Term + Expr | Term - Expr | Term
Term   ::= Factor * Term | Factor / Term | Factor
Factor ::= + Item | - Item | Item
Item   ::= ( Expr ) | Fn( Expr ) | Number
Fn     ::= Sin | Cos | другое...
Number ::= floating point literal number (плавающая точка литерала числа)
}
type
TExpressionParser = class( TParser )
protected
function  SkipToken( Value : char ) : boolean ;
function  EvalItem : double ; virtual ;
function  EvalFactor : double ; virtual ;
function  EvalTerm : double ; virtual ;
public
function  EvalExpr : double ;
end ;

implementation

uses SysUtils ;

function  TExpressionParser.SkipToken( Value : char ) : boolean ;
begin
{ возвращаем истину, если текущий признак Value,
и если так, то получаем следующий признак }
Result := Token = Value ;
if Result then NextToken ;
end ;

function  TExpressionParser.EvalItem : double ;

var Expr : double ;
Fn   : integer ;

begin
case Token of
toInteger : Result := TokenInt ;
toFloat   : Result := TokenFloat ;
'(' : begin
NextToken ;
Result := EvalExpr ;
CheckToken( ')' ) ;
end ;
toSymbol : begin
if CompareText( TokenString, 'SIN' ) = 0 then Fn := 1 else
if CompareText( TokenString, 'COS' ) = 0 then Fn := 2 else
Raise EParserError.CreateFmt( 'Неизвестный элемент "%s"', [ TokenString ]
) ;
NextToken ;
CheckToken( '(' ) ;
NextToken ;
Expr := EvalExpr ;
CheckToken( ')' ) ;
case Fn of
1 : Result := SIN( Expr ) ;
2 : Result := COS( Expr ) ;
end ;
end ;
else
Raise EParserError.CreateFmt( 'Неожидаемый символ "%s"', [ Token ] ) ;
end ;
NextToken ;
end ;

function  TExpressionParser.EvalFactor : double ;

begin
case Token of
'+' : begin
NextToken ;
Result := EvalItem ;
end ;
'-' : begin
NextToken ;
Result := -EvalItem ;
end ;
else Result := EvalItem ;
end ;
end ;

function  TExpressionParser.EvalTerm : double ;
var AToken : char ;
begin
Result := EvalFactor;
if SkipToken( '*' ) then Result := Result * EvalTerm else
if SkipToken( '/' ) then Result := Result / EvalTerm ;
end ;

function  TExpressionParser.EvalExpr : double ;
begin
Result := EvalTerm ;
if SkipToken( '+' ) then Result := Result + EvalExpr else
if SkipToken( '-' ) then Result := Result - EvalExpr ;
end ;

end.

--------------------------EvalForm.pas---------------------------

unit EvalForm;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Button1: TButton;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var s : string ;
MemStream : TMemoryStream ;
ExpressionParser : TExpressionParser ;
begin
{ get the string to evaluate }
s := Edit1.Text ;

{ создаем поток для работы с памятью, содержащий текст -
TParser может разбирать выражения из потока}
MemStream := TMemoryStream.Create ;
try
MemStream.SetSize( Length( s ) ) ;
MemStream.WriteBuffer( s[ 1 ], Length( s ) ) ;
MemStream.Position := 0 ;

{ создаем анализатор выражения, используя поток }
ExpressionParser := TExpressionParser.Create( MemStream ) ;
try
Label2.Caption := Format( 'Результат=%g', [ ExpressionParser.EvalExpr ]
) ;
finally
ExpressionParser.Free ;
end ;
finally
MemStream.Free ;
end ;
end;
end.

-------------------------EvalForm.dfm-----------------------------

object Form1: TForm1
Left = 216
Top = 102
Width = 433
Height = 300
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
TextHeight = 16
object Label1: TLabel
Left = 8
Top = 8
Width = 74
Height = 16
Caption = 'Выражение'
end
object Label2: TLabel
Left = 120
Top = 72
Width = 297
Height = 16
AutoSize = False
Caption = 'Результат='
end
object Edit1: TEdit
Left = 8
Top = 27
Width = 409
Height = 24
TabOrder = 0
Text = '(23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1'
end
object Button1: TButton
Left = 8
Top = 64
Width = 89
Height = 33
Caption = 'Оценка'
Default = True
TabOrder = 1
OnClick = Button1Click
end
end

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

Mike Scott
Mobius Ltd. [000508]


Delphi 1

Простое использование TParser

...можно ли с помощью TParser "вытащить" из строки целочисленные значения, разделенные между собой пробелом, например, из строки '345 998 223 546 777' получить пять чисел?

Как этот пример? Он парсирует текст из поле редактирования с именем Edit1 и помещает полученные числа с список с именем Listbox1:

procedure TForm1.Button1Click(Sender: TObject);
var Stream : TStream ;
s : string ;
begin
Stream := TMemoryStream.Create ;
try
{ получаем текст области редактирования и помещаем его в поток }
s := Edit1.Text ;
Stream.WriteBuffer( s[ 1 ], length( s ) ) ;

{ сбрасываем стартовую позицию потока и создаем парсер }
Stream.Position := 0 ;
with TParser.Create( Stream ) do try
{ "добываем" числа и добавляем их в список }
while Token <> toEOF do begin
CheckToken( toInteger ) ;  { возбуждаем исключение, если не toInteger }
Listbox1.Items.Add( IntToStr( TokenInt ) ) ;
NextToken ;
end ;
finally
Free ;
end ;
finally
Stream.Free ;
end ;
end;

Как вы можете видеть, бОльшая часть кода тривиальна: работа с потоком, его создание и освобождение, и парсер, естественно, с обработкой ошибок<g>. CheckToken проверяет, является ли текущий признак ожидаемым, и, если нет, генерирует исключительную ситуацию. В нашем случае мы ищем целые (toInteger), и читаем их из TParser.TokenInt. Просто!

Mike Scott. [000666]


Delphi 2

Подсказка по работе TRegIniFile

Я не обижусь, если мне кто-нибудь покажет как работать с регистрами Win95!

TRegIniFile работает почти так же, как и объект TIniFile. Вот пример кода, который может вам помочь:

var
Reg  : TRegIniFile;
begin
Reg := TRegIniFile.Create('');
// ReadString(Section, Ident, Default)
Result := Reg.ReadString('\Software\MyApp', 'InitialDir', 'c:\windows');
// WriteString(Section, Ident, Value)
Reg.WriteString('Software\MyApp', 'InitialDir', 'c:\windows');
Reg.Free;
end;

- Nick Bradbury [000902]


Delphi 2

Использование TRegIniFile

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

Я пробовал, и это работает. :-> К сожалению, способ использования параметров строки не очень интуитивен.

Как??

Попробуй следующее. Разместите на форме три компонента Label. Затем дважды щелкните на форме, тем самым создав скелет обработчика события формы OnCreate. Отредактируйте FormCreate() как показано ниже:

procedure TForm1.FormCreate(Sender: TObject);
var
Registry: TRegIniFile;

begin
Registry := TRegIniFile.Create(''); // имя файла не имеет значения

Registry.RootKey := HKEY_CLASSES_ROOT; // изменяем корень

// ищем акроним расширения файла проекта DPR
Label1.Caption := Registry.ReadString('.dpr', '', 'Ошибка');

// ищем текстовое описание данного акронима

Label2.Caption := Registry.ReadString(Label1.Caption, '', 'Ошибка');

// ищем для данного акронима/расширения команду оболочки (shell) Open

Label3.Caption := Registry.ReadString(Label1.Caption + '\Shell\Open\Command\', '', 'Ошибка');

Registry.Free;
end;

Соберите (Build) и запустите ваше приложение. На трех компонентах Label вы должны увидеть следующую информацию:

  DelphiProject

  Delphi Project File

  "C:\Program Files\Borland\Delphi 2.0\BIN\DELPHI32.EXE" "%1"
Они соответствуют трем значениям, найденным в системных регистрах.

- Tim Gooch [000963]


Сохранение и чтение из потока данных объекта

Для чтения и записи на диск большого количества записей данных объекта я использовал TFileStream и TMemoryStream. Ниже я привел пример, сохраняющий на диске c помощью потока содержание контейнера DataArray, насчитывающего несколько тысяч записей объектов:

DataStream := TFileStream.Create('vccmem.dat', fmCreate);
MakeDate := FormatDateTime('mmmm d, yyyy',date);
DataStream.Write(MakeDate, SizeOf(MakeDate));
RCount := DataArray.Size;
DataStream.Write(RCount,SizeOf(RCount));

for q := 1 to DataArray.Size do
begin
Application.ProcessMessages;
ARecord := DataArray[q] as TNameRecord;
DataStream.Write(ARecord.id, SizeOf(ARecord.id));
DataStream.Write(ARecord.first_name, SizeOf(ARecord.first_name));
DataStream.Write(ARecord.last_name, SizeOf(ARecord.last_name));
DataStream.Write(ARecord.title, SizeOf(ARecord.title));
DataStream.Write(ARecord.address, SizeOf(ARecord.address));
DataStream.Write(ARecord.city, SizeOf(ARecord.city));
DataStream.Write(ARecord.state, SizeOf(ARecord.state));
DataStream.Write(ARecord.zip, SizeOf(ARecord.zip));
DataStream.Write(ARecord.phone, SizeOf(ARecord.phone));
DataStream.Write(ARecord.fax, SizeOf(ARecord.fax));
DataStream.Write(ARecord.e_mail, SizeOf(ARecord.e_mail));
end;
DataStream.Destroy;

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

DataStream := TMemoryStream.Create;
DataStream.LoadFromFile('vccmem.dat');
DataStream.Read(MakeDate, SizeOf(MakeDate));
DataStream.Read(RCount, SizeOf(RCount));

for q := 1 to RCount do
begin
NameRecord := TNameRecord.Create;
DataStream.Read(NameRecord.id, SizeOf(NameRecord.id));
DataStream.Read(NameRecord.first_name,
SizeOf(NameRecord.first_name));
DataStream.Read(NameRecord.last_name,
SizeOf(NameRecord.last_name));
DataStream.Read(NameRecord.title, SizeOf(NameRecord.title));
DataStream.Read(NameRecord.address, SizeOf(NameRecord.address));
DataStream.Read(NameRecord.city, SizeOf(NameRecord.city));
DataStream.Read(NameRecord.state, SizeOf(NameRecord.state));
DataStream.Read(NameRecord.zip, SizeOf(NameRecord.zip));
DataStream.Read(NameRecord.phone, SizeOf(NameRecord.phone));
DataStream.Read(NameRecord.fax, SizeOf(NameRecord.fax));
DataStream.Read(NameRecord.e_mail, SizeOf(NameRecord.e_mail));
NameArray.Insert(NameRecord);
end;

[000248]


Ошибка чтения потока

В моем автономном приложении при чтении/записи из моей базы данных с помощью 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 [000918]


TStringList в TIniFile

Из "Visual Developer Journal" Июль/Июнь 1996 страница 108, unit IniStr автор Ed Jordan:

unit IniStr;
{Записал Ed Jordan}
interface

uses Classes;

type
TIniStringlist = class( TStringList )
public
procedure LoadFromIni( const FileName, Section: string);
procedure SaveToIni( const FileName, Section: string);
end;

implementation

uses IniFiles, SysUtils;

procedure TIniStringList.LoadFromIni( const FileName,Section: string);
var
Index: Integer;
Line: string;
begin
with TIniFile.Create( FileName ) do
try
ReadSectionValues( Section, Self);
for Index:= 0 to Count - 1 do
begin
{ Удаляем имя идентификатора ...}
Line:= Values[ IntToStr( Index ) ];
{ Удаляем тильду ... }
System.Delete( Line, 1, 1);
Strings[ Index ]:= Line;
end;
finally
Free;
end;
end;

procedure TIniStringList.SaveToIni( const FileName, Section: string);
var
Index: Integer;
Line: string;
begin
with TIniFile.Create( FileName ) do
try
EraseSection( Section );
for Index:= 0 to Count - 1 do
begin
{ Сохраняем белые пробелы, пустые строки ...}
Line:= '~' + Strings[ Index ];
WriteString( Section, IntToStr( Index ), Line);
end;
finally
Free;
end;
end;

end.

Применение:

var
L: TIniStringList;
begin
L:= TIniStringList.Create;
L.LoadFromIni('MyFile.Ini', 'Alati');
{Загружаем L..}
L.Free;
end.
[000223]


Delphi 1

Сортировка TStringList

Программа сортировки TStringList.Sorted для сравнения строк вместо String1 > String2 использует AnsiCompareText. Результаты не одни и те же! [000444]


Одной строкой

PChar в TStringList

Это просто. Допустим у нас имеется PChar P, содержащий символы перевода строки #13 или #13#10, и TStringList с именем TS, для копирования P в TS достаточно следующей команды:

TS.SetText(P);

- Neil [000633]


Delphi 1

Создание списка списков (TStringList)

Как мне создать TStringList, содержащий в строке имя объекта, и сам объект TStringList?

TStringList имеет возможность хранить для каждой строки свой указатель: см. свойство Objects. Чтобы понять принцип работы с указателями, смотри в электронной справке описание метода TStringList AddObject. Вот пример работы с методом:

StringList1.AddObject('Имя списка', TStringList.Create);

ПРЕДУПРЕЖДЕНИЕ: Delphi не удаляет эти объекты. Вы должны позаботиться об этом сами.

Вы можете получить доступ к связанному stringlist, назначая его переменной TStringList:

TempStringList := TStringList(StringList1.Objects[index]);

Приведенный ниже код правильно компилируется, правильно выполняется и правильно демонстрирует все вышесказанное. Form1 имеет только один компонент Label.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
StringList1, TempStringList: TStringList;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
StringList1 := TStringList.Create;
StringList1.AddObject('имя', TSTringList.Create);
TempStringList := TStringList(StringList1.Objects[0]);
TempStringList.Add('Привет');
Label1.Caption := TempStringList[0];
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: Longint;
begin
for i := 0 to StringList1.Count-1 do begin
TempStringList := TStringList(StringList1.Objects[i]);
TempStringList.Free;
end;
end;

end.

[000663]


Delphi 1

TstringList, владеющий объектами

В этом случае вам нужно освобождать объекты StringList точно также, как вы это делали без него. StringList.Free просто очистит список и строки, но не ассоциированные с ними объекты. Дело в том, что вы могли бы иметь указатели на объекты, например, в двух StringList, и вы могли бы захотеть освободить в одном список строк без освобождения объектов, содержащихся в другом.

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

TOwnerStringList = class(TStringList)
private
FOwnsObjects: Boolean;
public
constructor Create(AOwnsObjects: Boolean); override;
destructor Destroy; override;
end;

constructor TOwnerStringList.Create(AOwnsObjects: Boolean);
begin
inherited Create;
FOwnsObjects := AOwnsObjects;
end;

destructor TOwnerStringList.Destroy;
var
I : Integer;
begin
if FOwnsObjects then for I := 0 to MyStrLst.Count -1 do TObject(Objects[I]).Free;
inherited Destroy;
end;

Теперь, когда у вас есть взаимно-однозначное соответствие между списком строк и имеющимися объектами, то для создания нового списка, который уничтожал бы объекты при освобождении списка строк, вам необходимо выполнить команду: "MyStringList := TOwnerStringList.Create(True)". Для того, чтобы список вел себя как обычно, передавайте в методе Create в качестве параметра False, или просто используйте нормальный TStringList. [000665]


TstringList и потоки

Возможно ли выполнить StringList.SaveToStream во время процесса WriteComponent? Если необходимо создать код, сохраняющий каждую строку, могу ли я воспользоваться Stream.WriteStr, или мне необходимо сохранять длину в байтах + сами символы? (Все мои строки < 256 символов).

Вы можете легко записывать строки, если определите, что список строк вместо DefineBinaryPropery должен использовать DefineProperty. Чтение и запись должны выпоняться соответственно с помощью методов TReader и TWriter. Записывать вы можете приблизительно так:

Writer.WriteListBegin ;
for i := 0 to TheStringList.Count - 1 do
Writer.WriteString( TheStringList[ i ] ) ;
Writer.WriteListEnd ;

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

Reader.ReadListBegin ;
while not Reader.EndOfList do
TheStringList.Add( Reader.ReadString ) ;
Reader.ReadListEnd ;

- Mike Scott [000977]


Delphi 1

Пример TWriter/TReader

Вот что вы должны cделать для того, чтобы с помощью TWriter/TReader записать строку в поток. До сих пор для простоты я использую TMemoryStream.

Ключевыми являются вызовы Read/WriteListBegin и Read/WriteListEnd. Без них вы получите исключение.

procedure TForm1.Button1Click(Sender: TObject);
var sWrite,sRead : string[25];
MyStream : TMemoryStream;
MyWriter : TWriter;
MyReader : TReader;
begin
MyStream := TMemoryStream.Create;
MyStream.SetSize(4096);
MyWriter := TWriter.Create(MyStream,4096);
sWrite := 'sWriteContents';

MyWriter.WriteListBegin;
MyWriter.WriteString(sWrite);
MyWriter.WriteListEnd;
MyWriter.free;

MyStream.Seek(0,0);

MyReader := TReader.Create(MyStream,4096);
MyReader.ReadListBegin;
sRead := MyReader.ReadString;
MyReader.ReadListEnd;
MyReader.free;

Label1.Caption := sRead;
MyStream.free;
end;

[000645]


Высокоточный таймер

{
Имя файла: HRTimer.PAS V1.00
Создан: Апр 17 1997, 06:40, автор John Mertus
Обновлен #6: Окт 12 1997, 10:56 John Mertus

Оболочка для таймера высокой точности при создании приложений под
Win95/WinNT

Var
HRT : THRTimer

HRT := THRTimer.Create;
HRT.StartTimer;  Сброс таймера в ноль
HRT.ReadTimer;   Возвращает отсчитанное время в миллисекундах
начиная со времени старта

HRT.Free;

Список изменений
Версия  1.00 - Первый выпуск
}

{-----------------Модуль HRTimer-------------------John Mertus Апрель 97---}
Unit HRTimer;

{-------------------Объявления-------------------------------}

interface

Uses Windows;

Type
THRTimer = Class(TObject)
Constructor Create;
Function StartTimer : Boolean;
Function ReadTimer : Double;

private
StartTime : Double;
ClockRate : Double;

public
Exists    : Boolean;

End;

{--------------------------Реализация-----------------------------------}

implementation

{------------------Create-------------------------John Mertus----Мар 97-}
Constructor THRTimer.Create;

{ Получаем точное системное время и сохраняем его для дальнейшего       }
{ использования.                                                        }
{                                                                       }
{***********************************************************************}
 Var
QW : TLargeInteger;

BEGIN
Inherited Create;
Exists := QueryPerformanceFrequency(QW);
ClockRate := QW.QuadPart;
END;

{------------------StartTimer---------------------John Mertus----Мар 97-}

Function THRTimer.StartTimer : Boolean;

{ Получаем точное системное время и сохраняем его для дальнейшего       }
{ использования.                                                        }
{                                                                       }
{***********************************************************************}
 Var
QW : TLargeInteger;

BEGIN
Result := QueryPerformanceCounter(QW);
StartTime := QW.QuadPart;
END;

{-------------------ReadTimer---------------------John Mertus----Мар 97---}

Function THRTimer.ReadTimer : Double;

{ Получаем точное системное время и сохраняем его для дальнейшего       }
{ использования.                                                        }
{                                                                       }
{***********************************************************************}
 Var
ET : TLargeInteger;

BEGIN
QueryPerformanceCounter(ET);
Result := 1000.0*(ET.QuadPart - StartTime)/ClockRate;
END;

end.
[000265]


Delphi 1

FileReaderWriter-поток

Я скомпоновал небольшой модуль, облегчающий чтение и запись в поток объектов-не-компонентов. За основу взят базовый класс (TStreamable), имеющий пустые процедуры Load и Store, перекрываемые в потомках для выполнения специфических задач, плюс некоторые расширения классов TReader и TWriter, автоматизирующие работу с системными регистрами. Вы увидите это в нижней части этого совета. Надеюсь, вы найдете это полезным.

Процедуры Load и Store класса TStreamable и его потомков содержат параметры, делающие возможным чтение и запись методами классов TReader и TWriter (смотри файл помощи Component Writer's Help). Сохраняемая сущность меняется от класса к классу, поэтому для себя вы должны решить с чем вы будете работать.

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

Если еще во время разработки приложения вы знаете, объект какого класса вы будете сохранять/загружать и все, что вам нужно сделать, это инициализировать поток, filer и экземпляр объекта (только загрузка), то для этого можно использовать метод Load/Store.

Пример: (сохранение, FKnowObject - поле в TTest)

procedure TTest.StoreKnownObject(Filename: string);
var
S: TFileStream;
W: TEnhWriter;
begin
S := TFileStream.Create(Filename, fmOpenWrite);
W := TEnhWriter.Create(S, 1024);
FKnownObject.Store(W);
W.Free;
S.Free;
end;

(загрузка объекта, сохраненного выше, предполагает, что до этого момента был осуществлен вызов FKnowObject.Create)

procedure TTest.LoadKnownObject(Filename: string);
var
S: TFileStream;
R: TEnhReader;
begin
S := TFileStream.Create(Filename, fmOpenRead;
R := TEnhReader.Create(S, 1024);
FKnownObject.Load(R); {перезаписываем все предыдущие данные объекта}
R.Free;
S.Free;
end;

Имея список объектов, проще всего работать с ними в цикле.

Пример: (сохранение, список TKnownObjects)

procedure TTest.StoreKnownList(Filename: string; List: TList);
var
S: TFileStream;
W: TEnhWriter;
I: Integer;
begin
S := TFileStream.Create(Filename, fmOpenWrite;
W := TEnhWriter.Create(S, 1024);
W.WriteListBegin;
with List do
for I := 0 to Count -1 do
TKnownObject(Items[I]).Store(W);
W.WriteListEnd;
W.Free;
S.Free;
end;

(загрузка выше в пустой список)

procedure TTest.StoreKnownList(Filename: string; List: TList);
var
S: TFileStream;
R: TEnhReader;
K: TKnownObject;
begin
S := TFileStream.Create(Filename, fmOpenRead;
R := TEnhReader.Create(S, 1024);
R.ReadListBegin;
with List do
while not EndOfList do
begin
K.Create;
K.Load(R);
Add(K);
end;
R.ReadListEnd;
end;

Методы, которые я добавил к TReader/TWriter, действительно начинают работать только тогда, когда вы имеете дело с объектами двух и более классов (предок и потомок, разные классы от одного родителя и т.п.).

function TEnhReader.ReadStreamable: TStreamable

Читает из потока имя класса, вызывает FindClass для получения класса и затем создает его экземпляр. Затем вызывает Load для чтения данных объекта. Вероятно вы захотите объявить указатель на возвращаемое значение, имеющее тип последнего общего из всех возможных предков, *не* инициализуруйте это заранее.

procedure TEnhReader.ReadListItems(List: TList);

Список TList должен быть инициализированным, но пустым (будет вызван метод TList.Clear). Читает маркер StartOfList, затем вызывает ReadStreamable до тех пор, пока не достигнет маркера EndOfList, добавляет возвращаемые объекты в список к текущей позиции. Затем читает маркер EndOfList.

procedure TEnhWriter.WriteStreamable(AObj: TStreamable);

Записывает имя класса объекта в поток, затем вызывает Store для записи данных.

procedure TEnhWriter.WriteListItems(List: TList);

Записывает маркер StartOfList, в цикле приводит элементы списка к типу TStreamable и вызывает WriteStreamable для их записи. И, наконец, записывает маркер в конец списка.

--Вырезано--

{Базовый класс и его расширения для работы с потоковыми объектами}

{Авторские права принадлежат Don Croyle}
unit Strmstuf;

interface

uses Classes;

type
TEnhReader = class;
TEnhWriter = class;

TStreamable = class(TPersistent)
public
procedure Load(R: TEnhReader); virtual;
procedure Store(W: TEnhWriter); virtual;
end;

TStreamableClass = class of TStreamable;

TEnhReader = class(TReader)
public
procedure ReadListItems(List: TList);
function ReadStreamable: TStreamable;
end;

TEnhWriter = class(TWriter)
public
procedure WriteListItems(List: TList);
procedure WriteStreamable(AObj: TStreamable);
end;

implementation

procedure TStreamable.Load(R: TEnhReader);
begin
end;

procedure TStreamable.Store(W: TEnhWriter);
begin
end;

procedure TEnhReader.ReadListItems(List: TList);
begin
ReadListBegin;
with List do
begin
Clear;
while not EndOfList do
Add(ReadStreamable);
end;
ReadListEnd;
end;

function TEnhReader.ReadStreamable: TStreamable;
begin
Result := TStreamableClass(FindClass(ReadString)).Create;
if Result <> nil then Result.Load(Self);
end;

procedure TEnhWriter.WriteListItems(List: TList);
var
I: Integer;
begin
WriteListBegin;
with List do
for I := 0 to Count -1 do
WriteStreamable(TStreamable(Items[I]));
WriteListEnd;
end;

procedure TEnhWriter.WriteStreamable(AObj: TStreamable);
begin
WriteString(AObj.ClassName);
AObj.Store(Self);
end;

end.

--Вырезано-- [000576]


Создание события во время выполнения приложения

на примере переопределения события в Memo:

memo.onchange:=memo1Change;

procedure TForm1.Memo1Change(Sender: TObject);
begin
panel1.caption:='Содержимое было изменено';
end;
[000059]


Delphi 1

Имитация события MouseOff

Кто-нибудь знает, как отловить момент, когда мышь покидает область визуального компонента? Есть какой-нибудь эквивалент событию MouseMoveOff? Моя задача - сделать компонент невидимым, как только мышь покинет его область (возможно после события MouseDown, поскольку MouseUp еще не наступило).

В обработчике события tComponent.mousemove установите логический флажок, а в обработчике контейнера компонента MouseMove проверяйте этот флаг, если он равен True, "виртуальное" событие произошло и требует вашей обработки.

Успехов,
RAM [000670]


Delphi 1

Назначение события во время выполнения программы

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

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

Почуствуйте мощь RTTI (runtime type information)!

procedure SetEvent( ComponentWithEvent  : TComponent ;
const Event          : string ;
ComponentWithHandler : TComponent ;
const Handler        : string ) ;

var PropInfo : PPropInfo ;
Method   : TMethod ;

begin
PropInfo := GetPropInfo( ComponentWithEvent.ClassInfo, Event ) ;
if PropInfo = NIL then
Raise Exception.CreateFmt( 'Событие %s не найдено в классе %s',
[ Event, ComponentWithEvent.ClassName ] ) ;
Method.Code := NIL ;
if Assigned( ComponentWithHandler ) and ( Handler <> '' ) then begin
Method.Code := ComponentWithHandler.MethodAddress( Handler ) ;
if Method.Code = nil then
Raise Exception.CreateFmt( 'Класс %s не имеет метода с именем %s',
[ ComponentWithHandler.ClassName,
Handler ] ) ;
end ;
Method.Data := ComponentWithHandler ;
SetMethodProp( ComponentWithEvent, PropInfo, Method ) ;
end ;

{ примеры, показывающие как использовать SetEvent }
procedure TForm1.SetBtnClick(Sender: TObject);
begin
SetEvent( MenuItem, 'OnClick', Self, 'Test1Click' ) ;
end;

procedure TForm1.ClearBtnClick(Sender: TObject);
begin
SetEvent( MenuItem, 'OnClick', NIL, '' ) ;
end;

- Mike Scott [000763]


Delphi 1

Декларация события OnPassword

Мне необходимо написать процедуру для OnPassword с использованием TPasswordEvent. Но я никак не могу его прикрутить к объекту!

Объявление TPasswordEvent в исходном коде VCL неверно (исправлено в Delphi 2.0). Оно должно включать в себя ключевые слова "of object", как и все остальное объявления данного типа.

Есть два пути решения проблемы:

A) Изменить исходный код VCL

B) Создать не-стандартный обработчик события, работающий с неправильно декларированным.

Решение A - мой выбор, но для этого необходимо, чтобы вы имели копию исходного кода VCL. (Не пытайтесь пересобрать библиотеку VCL; просто измените файл и добавьте путь к файлу DB.PAS file в пути вашего проекта.)

Решение B немного более прагматичное и не требует изменения исходного кода VCL. Создайте следующую функцию:

procedure PasswordProc(Sender: TObject; var Continue: Boolean); far;
begin
Session.AddPassword('Harrison');
Continue := True;
end;

Затем измените обработчик события OnCreate...

procedure TForm1.FormCreate(Sender: TObject);
begin
Session.OnPassword := PasswordProc;
Table1.Active := True;
end;

Важно чтобы вы добавляли ключевое слово "far" в конец объявления данной функции. Если этого не сделать, вам понадобиться добавлять объявление функций в секцию модуля Interface, чтобы заставить Delphi скомпилировать их как "far"-процедуры (которые вызываются из другого модуля).

Если вы решаете воспользоваться методом A, то единственное отличие будет заключаться в том, что вам понадобиться добавить объявление процедуры к вашему классу формы, и в секции Implementation ваша процедура должна выглядеть примерно так:

procedure TForm1.PasswordProc(Sender: TObject; var Continue: Boolean);
begin
Session.AddPassword('Harrison');
Continue := True;
end;

Поскольку эта версия является функцией-членом, у нее существует преимущество при доступе к компонентам и private- или protected-членам вашей формы (TForm-производного класса).

- Tim Gooch [000797]


Задержка выполнения OnChange (Delphi 2)

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

Так как "работа кипит", я хотел бы отреагировать на изменение ItemIndex несколько позднее, например, 100 миллисекунд спустя. Вот что у меня получилось. Созданный в Delphi2, код подходит также и для Delphi 1. На простой форме располагаем компоненты ComboBox и Label. Необходимым дополнением является вызов Application.ProcessMessages, позволяющий избежать замедления работы PC, когда очередь сообщений для формы пуста.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls;

const
// Просто некоторая константа сообщения
PM_COMBOCHANGE = WM_USER + 8001;

// 500 миллисекунд
CWantedDelay = 500;

type
TForm1 = class(TForm)
ComboBox1: TComboBox;
Label1: TLabel;
procedure ComboBox1Change(Sender: TObject);
private
procedure PMComboChange(var message : TMessage); message PM_COMBOCHANGE;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
PostMessage(Handle, PM_COMBOCHANGE, 0, 0);
end;

procedure TForm1.PMComboChange(var message : TMessage);
const
InProc    : BOOLEAN = FALSE;
StartTick : LONGINT = 0;
begin
if InProc then begin
// Обновляем стартовое время задержки
StartTick := GetTickCount;

end else begin
// Организация цикла
InProc := TRUE;

// Инициализация стартового времени
StartTick := GetTickCount;

// Ожидаем истечения стартового времени.
// Пока стартовое время не исчерпалось, позволяем операционной системе обрабатывать сообщения
while GetTickCount - StartTick < CWantedDelay do Application.ProcessMessages;

// Иллюстративное приращение счетчика, задающее некоторую реальную работу обработчику события OnChange
Label1.Caption := IntToStr ( StrToIntDef ( Label1.Caption, 0 ) + 1);

// Завершение цикла
InProc := FALSE;
end;
end;

end.
[000060]


Delphi 1

Организация задержки I

Организация задержки - все еще большая головная в Delphi. Я использую Delphi 1 и пытаюсь организовать задержку 2 ms с погрешностью -0 ms +1 ms. Может кто-то уже решал подобную проблему? Организация цикла не позволяет достичь такой точности. Стандартный таймерный компонент не позволяет работать с частотой выше чем 18.2 times/sec.

Приведу модуль, который я использовал при создании 16-битного хранителя экрана (screen saver). В нем есть переменная DelayInit, объявленная глобально и инициализируемая во время создания формы как показано ниже:

DelayInit := False;
Delay(0);  {Проводим инициализацию и присваиваем 0 для дальнейшей калибровки}

Этим мы указываем на необходимость калибровки для конкретной системы.

unit Globals;

interface

Uses WinProcs, WinTypes, Messages,Classes, Graphics, IniFiles;

Const
OT_USER = 1;

Var
SsType : Integer;
{  iObjL  : Integer;  { Текущая левая координата объекта }
{  iObjR  : Integer;  { Текущая правая координата объекта }
{  iObjT  : Integer;  { Текущая верхняя координата объекта }
Finish     : Boolean;
TestMode   : Boolean;                                    { True если режим тестирования }
LoopsMs    : LongInt;                                    { Ms циклов }
ScreenWd   : Integer;                                    { Ширина экрана }
ScreenHt   : Integer;                                    { Высота экрана }

SpotSize   : Integer;                                    { Размер точки }
SpotSpeed  : Integer;                                    { Скорость точки }

DelayInit  : Boolean;                                    { True если цикл задержки инициализирован }

Procedure Delay(Ms : Integer);                             { Задержка для Ms миллисекунд }
Procedure CursorOff;                                       { Включение курсора } Procedure CursorOn;                                        { Выключение курсора }
{$IFDEF NOVELL}

{$ENDIF}
 implementation

Uses
SysUtils,
Toolhelp;

Procedure CursorOff;                                        { Выключение курсора } Var
Cstate : Integer;                                         { Текущее состояние курсора }
Begin
Cstate := ShowCursor(True);                               { Получаем состояние }
While Cstate >= 0 do Cstate := ShowCursor(False);         { Пока состояние >= 0 курсор выключен }
End;

Procedure CursorOn;                                         { Выключаем курсор } Var
Cstate : Integer;                                         { Текущее состояние курсора }
Begin
Cstate := ShowCursor(True);                               { Получаем состояние }
While Cstate < 0 do Cstate := ShowCursor(True);           { Пока состояние < 0 курсор включен }
End;

Procedure Delay(Ms : Integer);                              { Задержка для Ms миллисекунд }
{Если Ms равно 0, проводим калибровку }
Var
L,MaxLoops,StartL,EndL,Down,Up,Res : LongInt;             { Локальные переменные }
Ti  : TTimerInfo;
Begin
Up := 0;
Down := 100000;
if Not DelayInit then begin
Ti.dwSize := sizeof(LongInt) * 3;
TimerCount(@Ti);
StartL := Ti.dwmsSinceStart;                     { Получаем время старта }
if Not DelayInit then begin                            { Включаем тест }
for L := 0 to 100000 do begin                        { Организуем цикл с числом проходов равным 100000 }
Dec(Down);                                         { Уменьшаем счетчик }
Res := Abs(Down - Up);                             { Разница }
if Res = 0 then Inc(Res);                          { Сверка }
Inc(Up);                                           { Приращение }
end;
end;
TimerCount(@Ti);
EndL := Ti.dwmsSinceStart;                             { Получаем время старта }
LoopsMs := 100000 Div (EndL - StartL);      { Вычисляем показатель MS }
DelayInit := True;                                     { Откалибровали }
end
else begin
if Ms = 0 then Exit;
MaxLoops := LoopsMs * Ms;                              { Получаем необходимое количество циклов }
for L := 0 to MaxLoops do Begin                        { Организация цикла }
Dec(Down);                                           { Уменьшаем счетчик }
Res := Abs(Down - Up);                               { Получаем разницу }
if Res = 0 then Inc(Res);                            { Сверка }
Inc(Up);                                             { Приращение }
end
end;
End;

end.
[000264]


Одной строкой

Организация задержки II

Procedure Delay (Seconds: Word);
Var
Later: TDateTime;
Begin
Later := Now + (Seconds / (24.0 * 60.0 * 60.0));
While Now < Later do Application.ProcessMessages;
end;
[000652]


Работа в фоне

Я пишу программу в 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.
[000316]


Delphi 1

Делегирование события

...я вижу что событие делегировано, но почему вы считаете, что это отход от ООП? Тем не менее, Delphi это использует при каждом определении обработчика события.

Вот как поступить в вашей ситуации:

  1. Определите тип процедуры, использующейся в качестве обработчика события. Допустим, ваш обработчик OnCalculate имеет один параметр типа Integer (присутствующий лишь для демонстрации идеи).

    type
    TCalculateEvent = procedure(I: Integer) of object;

  2. Теперь объявите ваш класс:

    type
    TSomeClass = class(TObject)
    private
    FOnCalculate: TCalculateEvent;
    procedure DoCalculate(I: Integer);
    public
    property OnCalculate: TCalculateEvent read FOnCalculate
    write FOnCalculate;
    end;

  3. Метод DoCalculate совсем простой:

    procedure TSomeClass.DoCalculate(I: Integer);
    begin
    if Assigned(FOnCalculate) then FOnCalculate(I);
    end;

Теперь вы можете присваивать значение объекту TSomeClass, и назначать любую процедуру событию OnCalculate (естественно, при условии, что ее объявление соответствует объявлению TCalculateEvent).

-Steve [000671]


Delphi 1

Получение имени обработчика события

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

procedure TForm1.Button3Click(Sender: TObject);
var
P: record case Integer of
1: (E: TNotifyEvent);
2: (P: Pointer);
end;
begin
P.E := Button1.OnClick;
Panel1.Caption := 'Обработчик события = '+ MethodName(P.P);
ShowMessage(Format('%p', [P.P]));
end;

[000695]


Delphi 1

Синтаксис ссылки на событие

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

По всей видимости вам придется использовать две временные переменные. Попытайтесь сделать следующее:

var
ClickMethod: TNotifyEvent;
B1Click: TNotifyEvent;
...
ClickMethod := Button1.OnClick;
B1Click := Button1Click;
if @ClickMethod = @B1Click then messagebeep(0);

Kurt [000788]


Совместное использование Delphi 1.0 и 2.0

Что рекомендует Borland по поводу организации дискового пространства Delphi версии 1.0 и 2.0 для использования обоими версиями без проблем одного и того же исходного кода?

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

Примерно такую же схему я использую и при работе с компонентами: модули регистрации я размещаю в различных модулях, например, XxxReg.pas для Delphi 1.0 и XxxReg32.pas для Delphi 2.0. Формат файлов ресурсов в WIN32 также другой, что приводит к необходимости иметь соответствующие XxxReg.dcr и XxxReg32.dcr, содержащие иконки для палитры компонентов. В качестве альтернативы вместо двух DCR-файлов возможно использование единственного файла Reg.pas и двух RES-файлов, и директивы {$R ...}, обернутой в директивы условной компиляции, управляющие выбором загрузки одного из файлов. (Смотрите ниже дополнение от Dan Miser).

При переключении с Delphi 2.0 на 1.0, вы должны или сделать "build all", или создать bat-файл для удаления всех DCU файлов.

Наконец, вы можете задавать различные выходные (output) каталоги для каждого проекта в Delphi 1 и 2. С помощью данного способа вы можете хранить все DCU и EXE файлы в отдельных каталогах. Для этой цели в каталоге приложения я использую два подкаталога с именами 16Bit и 32Bit.

- Mike Scott.

Дополнение от Dan Miser:

В момент регистрации Delphi компонента в палитре компонентов, она ищет соответствуюшие файлы DCR (имеющие то же имя, что и модуль регистрации). Как мы знаем, затем происходит линковка. Поскольку Delphi не находит DCR-файл с подходящим именем, в нормальной ситуации он должен использовать иконку по умолчанию. Тем не менее, связывание файла ресурсов посредством директивы $R позволяет Delphi указать, что имеется иконка с тем же именем, что и у регистрируемого класса, таким образом Delphi удается установить связь между иконкой и компонентом.

Образец списка файлов компонента:

XXXREG.R16 16-битный DCR файл
XXXREG.R32 32-битный DCR файл
XXXREG.PAS Модуль регистрации компонента

unit XXXREG.PAS

interface

uses Classes;

procedure Register;

implementation

{$IFDEF WIN32}
{$R XXXREG.R32}
{$ELSE}
{$R XXXREG.R16}
{$ENDIF}
procedure Register
begin
{Здесь расположен ваш код регистрации}
end;

end.

[000923]


Получение констант с определением ошибки функцией LoadStr

Возбуждение исключения и передача строковой константы ошибки из CONSTS.PAS (как это делалось в Delphi 1 и Delphi 2) в Delphi3 невозможна. Например:

raise SomeException.Create(LoadStr(SInsertLineError));

в Delphi3 теперь не работает. Я предлагаю использовать выражение

raise SomeException.Create(
{$IFNDEF VER100}LoadStr{$ENDIF}
(SInsertLineError));

для вызова функции LoadStr "по нужде", устаревшей почему-то для этих целей в Delphi 3.

При попытке вызвать данную функцию в Delphi 3 (для получения типа ошибки, декларированной в модуле CONSTS(.PAS/.DCU)), мы получаем следующую ошибку компилятора: "Incompatible types: 'Integer' and 'String'"

Однако в Delphi 4 данная оплошность исправлена и вроде как документирована. Почитайте в хелпе на тему "resourcestrings", посмотрите сырцы и все сразу станет понятно и просто. [000061]


Delphi 1

Переход с Oracle на Interbase

Я пытаюсь преобразовать мою базу данных на 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.

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

Как я уже говорил выше: директивы компилятора.

Shawn Wu [000699]


Delphi 1

Visual Basic "Beep" в Delphi

Вам нужна процедура MessageBeep(BeepType: Word);

Функция MessageBeep проигрывает звук формата wave, соответствующий системному уровню "тревоги" (alert level). Звук для каждого уровня тревоги описан в секции [sounds] файла инициализации WIN.INI.

BeepType -1 (в паскале: Word($FFFF)) производит стандартный звук с помощью системного динамика, MB_ICONASTERISK проигрывает запись SystemAsterisk из секции [sounds] файла WIN.INI, MB_ICONEXCLAMATION проигрывает запись System Exclamation, MB_ICONHAND проигрывает запись SystemHand, MB_ICONQUESTION проигрывает запись SystemQuestion и MB_OK проигрывает SystemDefault.

Dr. Bob (drbob@pi.net) [000690]


Delphi 1

Ошибка сохранения текста в Memo

При использовании примера текстового редактора (TextEditor), всякий раз, когда я использую функцию выравнивания (center, left или right) или Wordwrap, свойство Memo1.Modified сбрасывается в False!

Воспроизведение ошибки:

  1. Запустите пример текстового редактора
  2. Откройте любой текстовый файл, используя File|Open
  3. Создайте новый файл, используя File|New
  4. Напечатайте какой-либо текст
  5. Разместите окна рядом, используя Windows|Tile
  6. Модифицируйте открытый вами текстовый файл, включив в него несколько пробелов
  7. Возвратитесь к новому файлу и отцентрируйте текст
  8. Выйдите из программы, используя File|Exit
  9. Программа НЕ попросит сохранить ваш новый файл, поспольку флаг modified был сброшен в False!
[000319]


Delphi 1

Ошибка метода ItemAtPos компонента ListBox

Оказывается, что метод ItemAtPos компонента ListBox - печальная жертва одной ошибки. Справочная система сообщает, что если вы вызываете ItemAtPos с параметром Existing, установленным в False и позиция курсора находится не над существующим элементом списка, функция возвращает позицию ПОСЛЕДНЕГО элемента списка.

ОШИБКА: TListBox.ItemAtPos(Point(X,Y), False) НЕ возвращает позицию последнего элемента списка когда курсор не над элементом. В этом случае функция возвращает позицию следующего, не существующего элемента списка. [000345]


Delphi 1

Ошибка фунциии GetTextLen компонента Memo

По всей видимости, функция GetTextLen в компоненте Memo работает не совсем правильно.

Загрузите в Memo1 большой текстовый файл.

var {пример из файла помощи}
Buffer: PChar;
Size: Byte;
begin
Size := Memo1.GetTextLen;
Inc(Size);
GetMem(Buffer, Size);
Memo1.GetTextBuf(Buffer, Size);
...   {не относящийся к делу код...}
FreeMem(Buffer, Size);
end;

Проблема: Memo1.GetTextLen возвращает размер выводимого, а не всего текста. [000350]


Delphi 1

Ошибка фунциии Print.EndDoc

Да, EndDoc проверяет флаг FAborted, но вызывает EndPage, даже если FAborted равно True. EndDoc используется только тогда, когда печать завершена полностью и *успешно*.

Процедура Abort предполагает вызов Windows API AbortDoc(), но не делает этого и, следовательно, прерывание процесса печати не останавливает работу принтера. Поэтому, для обхода этой ошибки вам следует вызвать

WinProcs.AbortDoc(Printer.Handle);

Я исправил модуль PRINTERS.PAS, после чего GPF пока не возникал...

CheckPrinting(True);
AbortDoc(Canvas.Handle);
FAborted := True;
WinProcs.EndDoc(DC);

- Garry Prefontaine [000409]


Delphi 1

Ошибка в DriveComboBox

У меня была серия неудач, когда Delphi не смог загрузить некоторые формы и мой .EXE GPed. И всякий раз ошибка была связана с файлом LANGENG.DLL

Складывается впечатление, что виновником здесь является Drive combo box. У меня ошибка возникла только когда в диске D: (CD-ROM) была копия игры 7th guest. Этот CD имел нулевой объем и, естественно, не имел файлов в корневой директории.

Устанавливая свойство Uppercase в False, проект в этом случае вызывал ошибку в User.exe. [000424]


Delphi 1

Ошибка прокручивания TOutLine

Да, TOutline содержит ошибку реализации. По неизвестной причине, если у компонента есть горизонтальная полоса прокрутки, событие OnDrawItem не возникает. Установите только вертикальный скроллбар, или не устанавливайте их вовсе, это решит проблему. [000429]


Delphi 1

Ошибка StringList.Find

TStringList.Find предполагает что список отсортирован, в противном случае метод Find терпит неудачу. Вероятно реальная ошибка (если она одна) в том, метод Find располагается в секции public. Для предотвращении такой путаницы его нужно было бы упрятать в секцию protected.

Вместо этого применяйте IndexOf, который использует метод Find только в том случае, если список отсортирован. [000450]


Delphi 1

Компонент OpenDialog - ошибки и их исправление

При использовании в Delphi диалогового окна Opendialog (с Multiselect=true) и выборе более одного файла из корневой директории, возвращаемые значения содержат две косые черты вместо одной. Для примера:

c:\\autoexec.bat
c:\\config.sys

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

Если вы хотите это исправить (и имеете исходный код VCL), найдите строчку 1128 в DIALOGS.PAS. Она выглядит так:

FFiles.Add(DirPart+'\'+FilePart);

Измените это на:

FFiles.Add(AddBkSlash(DirPart)+FilePart);

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

function AddBkSlash(const S:String):string;
begin
Result := S;
if S[Length(S)] <> '\' then Result := Result+'\';
end;

Pat [000471]


Delphi 1

Неверная документация по THelpEvent

В документации:

THelpEvent = function (Command: Word; Data: Longint): Boolean of object;

ФАКТИЧЕСКИЕ параметры:

THelpEvent = function (Command: Word; Data: Longint;
var CallHelp: Boolean): Boolean of object;

[000679]


Delphi 1

Cannot optimize ...not EXE... (не могу оптимизировать... не EXE...)

Она включена в файл DELPHI\README.TXT. Ошибка происходит при включенной опции "Optimize for size and load time" (оптимизировать по размеру и времени загрузки), когда оптимизатор не может справиться со своей задачей. Выключите эту опцию и взамен используйте программу W8LOSS.EXE, как написано в README. [000680]


Delphi 1

Конфликт с Lotus Notes

...это больше похоже на конфликт между отладчиком Delphi IDE и утилитой "разрешения конфликтных ситуаций" под названием Quincy, входящей в поставку Notes. Quincy пишет содержимое стека в текстовый файл в момент краха Notes. К сожалению, Quincy вступает в конфликт с кучей других программ. К счастью, Quincy не требуется для работы Notes. Просто переименуйте QNCW.EXE в вашем каталоге Notes на что-нибудь другое, например, QNCW.SAV. [000681]


Delphi 1

Ошибка TOutline ChangeLevelBy

...я, похоже, не могу получить для работы уровень ChangeLevelBy(-1), тем не менее, если вам необходимо переместить элемент на один уровень назад, то это можно сделать так:

with Outline1[Outline1.SelectedItem] do
if Level > 1 then moveto(Parent.Index,oaAdd);

[000682]


Delphi 1

Ошибка csDropDownList/csDropDown

Тема: Свойство Style во время выполнения программы??

Проблема в том, что csDropDownList (и, также, csDropDown) определен в _двух_ различных модулях, StdCtrls и DBLookup. В зависимости от порядка следования молулей в списке uses, вы получаете или одни характеристики, или другие. Вы можете избежать двоякого толкования и привязаться к модулю с помощью его имени, например так:

if Combo.Style = StdCtrls.csDropDownList then...

-Steve Schafer [000694]


Delphi 1

Ошибка DDE/WinWord

Я нашел ошибку в DDEMAN.DCU.

В процедуре TDdeServerItem.CopyToClipboard пропущен вызов ClipBoard.Open. Я потратил на поиск ошибки 2 дня, зато теперь я могу соединиться с WinWord.

Gerald Dachs

Дополнения

Используя TDdeServerItem, я не мог копировать в буфер обмена и впоследствии вставлять данные в Excel. Чтобы проверить сказанное, достаточно запустить программу ddesrvr. Выберите "копировать" и посмотрите буфер обмена стандартной системной смотрелкой. Она сообщит вам "Unrecognized format" (неопознанный формат).

Для устранения этих досадных ошибок я внес следующие изменения в ddeman.pas:

  1. Добавьте Clipboard.Open перед первой попыткой TDdeServerItem.CopyToClipboard (только перед первой попыткой).

  2. Также в TDdeServerItem.CopyToClipboard, я добавил другой null в конец LinkData. Не уверен, что это необходимо, но я думаю, что список необходимо терминировать двумя нулями (null).

Sam Lissok [000700]


Delphi 1

Ошибка конфигурации BDE

Я ищу противоположность SetRange, что-либо типа GetRange, но не нахожу этого ни в Delphi API, ни в BDE API.

В электронной справке обзор этой темы помещен в Filter Modes. Там вы можете узнать, что EditRangeStart и EditRangeEnd переводят таблицу в модальное состояние SetKey, где соответствующим критерием для включения/выключения фильтра служит отдельная запись, Метод ApplyRange возвращает в режим таблицы. Вот пример применения критерия фильтра (Filter criteria):

Table1.EditRangeStart; { Устанавливаем начальный ключ }
Label1.Caption := Table1.Fields[0].AsString;
Table1.EditRangeEnd; { Устанавливаем конечный ключ }
Label2.Caption := Table1.Fields[0].AsString;

[000704]


Delphi 1

Ошибка диалога настройки принтера

Я разместил в своем приложении вызов диалога настройки принтера. Он вызывается из моего меню PrinterSetupDialog1.Execute ... пока вроде все нормально. Теперь вот что странно: мое приложение может вызвать его только один раз. При попытке вызвать его вторично ничего не происходит. Диалог не появляется.

Это "недавнообнаруженная" проблема. Для ее решения необходимо вызывать GetPrinter и SetPrinter перед каждым вызовом PrinterSetupDialog1.Execute:

var
Driver, Device, Port: array[0..79] of Char;
Mode: THandle;
begin
...
GetPrinter(Driver, Device, Port, Mode);
SetPrinter(Driver, Device, Port, 0);
PrinterSetupDialog1.Execute;
...
end;

Та же проблема возникает при использовании кнопки "Setup" из диалога печати.

-Steve Schafer [000719]


Delphi 1

Ошибка TListBox MeasureItem

MeasureItem не работает, если элементы были добавлены через AddObject.

AddObject работает в два этапа. Сначала добавляется строка, затем указатель на объект. Проблема заключается в том, что добавление строки инициирует событие MeasureItem прежде, что происходит присвоение указателя на объект, поэтому в обработчик события MeasureItem вместо указателя попадает *мусор*. Не nil, не данные, а простой мусор.

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

Конечно, это все криво, но другого решения я пока не знаю.

-Scott Samet [000720]


Delphi 1

Printer.Abort не работает...

Это может помочь:

procedure TForm1.Button1Click(Sender: TObject);
begin
Printer.BeginDoc;
Printer.Canvas.TextOut(100,100, 'Программирование - это просто');
if CheckBox1.Checked then {Прерывание работы принтера.}
begin
Printer.Abort;
WinProcs.AbortDoc(Printer.Canvas.Handle);
Printer.EndDoc; {Наводим порядок.}
exit;
end;
Printer.EndDoc;
end;

- William E Murto [000727]


Delphi 1

Ошибка Grid RangeSel+RowSel

Тема: Ошибка Grid RangeSel+RowSel
От: Bill Goelkel 71725,455
К: Все

Компонент: TStringGrid, TDrawGrid

Проблема: Если в свойстве Options goRangeSelect и goRowSelect имеют True, то не выбирается диапазон, состоящий из последовательных строк. Вместо этого выделяются множетсво разрозненных строк.

Решение: В исходных файлах VCL, строка 2,310 файла GRIDS.PAS:
procedure TCustomGrid.MoveAnchor, измените FAnchor.Y на FAnchor.X,
теперь это должно выглядеть так:

if goRowSelect in Options then FAnchor.X := ColCount-1;

- Bill Goelkel [000781]


Delphi 1

Ошибка в mmsystem.pas

"Объявление WaveInClose неверно."

Вы можете просто вновь объявить это сами:

function WaveInClose(hWaveIn: THandle): Word; far; external 'MMSYSTEM'  index 505;

-Steve Schafer [000790]


Delphi 1

GPF c любым Memo

Memos и DBMemos не будут работать, если в настройках компилятора включена опция 'Smart Callbacks'.

- Richard Shotbolt [000861]


Delphi 1

Проблемы с диалогом печати (PrintDialog)

...в итоге я получил действительно большую проблему. У меня не получается вызывать диалоги PrintDialog и PrinterSetupDialog более одного раза. Метод вызова каждого диалога у меня привязан к определенному пункту меню и соответствующим кнопкам SpeedButton. После одного или двух нажатий оба диалога перестают работать, т.е. при их вызове ничего не происходит. Я проверял это на трех других компьютерах, работающих под операционной системой Windows for Workgroups.

Вот что нужно сделать:

В DIALOGS.PAS измените

{ 1530 }   hWndOwner := Application.Handle;
{ 1531 }   if TaskModalDialog(@PrintDlg, PrintDlgRec) then
{ 1532 }     SetPrinter(hDevMode, hDevNames)
{ 1533 }   else

на

{ 1530 }   hWndOwner := Application.Handle;
{ 1531 }   SetPrinter(hDevMode, hDevNames);
{ 1532 }   if not TaskModalDialog(@PrintDlg, PrintDlgRec) then

и

{ 1582 }   if Result then
{ 1583 }   begin
{ 1584 }     SetPrinter(hDevMode, hDevNames);
{ 1585 }     F := Flags;

на

{ 1582 }   SetPrinter(hDevMode, hDevNames);
{ 1583 }   if Result then
{ 1584 }   begin
{ 1585 }     F := Flags;

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

procedure InitPrinter;
var
Device, Driver, Port: array[0..79] of Char;
DevMode: THandle;
begin
GetPrinter(Device, Driver, Port, DevMode);
SetPrinter(Device, Driver, Port, DevMode);
end;

-Steve Schafer [000864]


Delphi 1

Проблема фильтров в компоненте SaveDialog

Для диалога SaveDialog1 я установил 3 фильтра. Она классно появляются при открытии выпадающего списка. Что мне необходимо сделать: мне нужно "прочесть" содержимое выбранного пользователем из списка фильтра для того, чтобы при последующем открытии SaveDialog1 данный элемент предлагался ему в первую очередь (свойство ItemIndex).

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

Если у вас имеется исходный код VCL, вы можете это исправить, скорректировав TOpenDialog.DoExecute в Dialogs.PAS. Просто добавьте следующее:

function TOpenDialog.DoExecute(Func: Pointer): Bool;
CommonDialogList.Remove(Self);
if Result then
begin
ProcessMultipleSelection(lpstrFile);
FFileName := FFiles.Strings[0];
FFilterIndex := nFilterIndex;                   {<=== вот что вам нужно добавить}
if (Flags and OFN_EXTENSIONDIFFERENT) <> 0 then
FOptions := FOptions + [ofExtensionDifferent]

Не (повторяю: не) изменяйте секцию interface кода VCL, если вы собираетесь продолжать пользоваться IDE.

- Owen Barder [000891]


Delphi 1

Ошибка объекта TListBox

Я получаю ошибку index out-of-range (индекс за пределами диапазона) при вызове DetailList.Items.Objects[X], когда X равен нулю, при дальнейшем тестировании ошибка Detail.Items[X] исчезает, даже когда X равен нулю. В чем дело?

Эта ошибка, похоже, происходит если я привожу -1 к типу TObject и размещаю ее в ListBox в массиве Items.Objects.

Это вызвано ошибкой в TListBoxStrings:

function TListBoxStrings.GetObject(Index: Integer): TObject;
begin
Result := TObject(SendMessage(ListBox.Handle, LB_GETITEMDATA, Index, 0));
if Longint(Result) = LB_ERR then
raise EStringListError.Create(LoadStr(SListIndexError));
end;

LB_ERR, вы наверное догадались, -1!

- Ralph Friedman [000997]


Ошибка в руководстве "Getting Started" на странице 42

Я только что установил Delphi 2.0, все прошло успешно и без единой ошибки, в процессе инсталляции коментарии и замечания не возникали.

Далее в Delphi 2.0 я открываю руководство "Getting Started" (Подготовка). Согласно странице 42, "Adding a display grid" (добавление и отображение сетки данных), добавляю на форму DBGrid, устанавливаю DataSource в GDSDataModule.CustomerSource, но данные в DBGrid не отображаются, хотя на странице 42 написано "Immediately, the data is displayed in the DBGrid" (данные немедленно будут отображены в DBGrid).

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

При вызове из меню Delphi "Database Explorer" все таблицы и их данные видятся без проблем.

Таблицу необходимо открыть. Установите свойство Active компонента Тable в True.
[000062]


Delphi 2

Распределение памяти TstringList

Я создаю объект TStringList и добавляю 10,000 десятибайтовых строк по 1000 строк за раз, после чего, с помощью функции GetHeapStatus, получаю информацию о куче. Ниже представляю вам результаты:
 число   TotalAddrSpace   TotalAllocated
     0        1,048,576           11,268
 1,000        1,048,576           40,848
 2,000        2,097,152           69,344
 3,000        3,145,728           97,888
 4,000        4,194,304          126,296
 5,000        6,291,456          154,868
 6,000        9,437,184          183,268
 7,000       12,582,912          211,828
 8,000       14,680,064          240,248
 9,000       18,874,368          268,800
10,000       23,068,672          297,208
Я гляжу что Delphi 2.0 для моих данных размером 300Кб выделила памяти аж 23Мб! Ну и кому это понравится? У меня есть программа, заполняющая TStringGrid, и она работает вдвое медленне чем в версии Delphi 1.0! Похоже, что вся эта заторможенность вызвана чрезмерным распределением памяти.

- Mark Ford

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

-Steve Schafer [000916]


Delphi 2

Ошибка TQuery в Delphi 2

Всякий раз при возврате пустого результата в Delphi 2 при работе с Tquery я получаю ошибку INVALID FLOATING POINT OPERATION (неверная операция с плавающей точкой). Я что-то неправильно делаю, или это новая характеристика Delphi?

Я получал эту ошибку и уже давно ее исправил, (только не спрашивайте у меня почему) изменив синтаксис с 'WHERE a = "Hi"' на 'WHERE a IN ("Hi")'.

- Robert A. Dickinson [000917]


Delphi 2

Delphi 2.0 и оболочка Win95

Когда я дважды щелкаю в Проводнике на файле, я получаю окно с ошибкой, гласящее:

    Error in module TestBu~1.dpr. Module header is missing or incorrect.
    (Ошибка в модуле TestBu~1.dpr. Заголовок модуля потерян или неверен.)
В Delphi 2.0 информация, хранимая в регистрах, и необходимая для ассоциации и запуска проекта по его типу и имени файла, поддерживает в среде Win95 только 8 символов. Для исправления сложившийся ситуации, перейдите в меню Проводника и выберите пункт View|Options. Выберите закладку File Types и прокрутите список до появления регистрации расширений файлов Delphi. Выберите первый, щелкните на кнопке Edit, и дважды щелкните в списке на строке с командой Open. Заключите имя exe-файла в двойные кавычки и добавьте "%1", все это должно выглядеть примерно так:
"D:\Borland\Delphi 2.0\Bin\Delphi32.EXE" "%1"
Осуществите описанные выше действия для всех четырех зарегистрированных типов файлов Delphi.

- Mike Scott. [000921]


Delphi 2

Проблема с HeapAlloc

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

Похоже их объявления были удалены из WINDOWS.PAS:

HEAP_NO_SERIALIZE        = 1
HEAP_GENERATE_EXCEPTIONS = 4
HEAP_ZERO_MEMORY         = 8

-Steve Schafer [000929]


Delphi 2

Проблемы с FORMS.PAS 2.0

В FORMS.PAS зловредная ошибка!!! Если Borderstyle установить в bsDialog, то невозможно использовать biHelp-BorderIcon. Почему? Ответ в процедуре CreateParams в строке:

Icons := Icons * [biSystemMenu];

Данная строка фильтрует все, кроме biSystemMenu. Поэтому флаг biHelp и становится здесь недоступен! Правильная строка должна быть такой:

Icons := Icons * [biSystemMenu, biHelp];

Я думаю что отчасти проблема заключается в несоответствии с Win95-MDI-Parent-Form (родительской MDI формы). Родительская форма клиента (Client Parentform) не в 3D (WS_EX_CLIENTEDGE). Любое другое Win95-MDI-приложение имеет 3D-эффект. Решение данной проблемы очень простое. ClientHandle в процедуре CreateWnd должен генерироваться с CreateWindowEx вместо CreateWindow, а ExtendedStyle WS_EX_CLIENTEDGE должен устанавливаться следующим образом:

FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE,'MDICLIENT', nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or WS_CLIPSIBLINGS or MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0, HInstance, @ClientCreateStruct);

Я надеюсь эта ошибка будет устранена уже в первой заплатке к Delphi2.0.

- Rolf Frei [000959]


Delphi 2

Проблема Reset текстового файла

Имеется известная ошибка в Reset: если вы используете это в открытом текстовом файле, поля буфера файла _не_ сбрасываются в начало буфера. Вы можете обойти это, используя CloseFile, AssignFile и Reset вместо использования только Reset или "вручную" сбрасывая буфер:

Reset( filevar );
with TTextRec(filevar) do SetTextBuf(filevar, BufPtr^, BufSize);

- Peter Below [000961]


Delphi 2

Ошибка в модуле Math

Функции MinValue и MaxValue в модуле Math возвращают значение, обратное ожидаемому (неверный код в math.pas).

- Christer Matson [000979]


Delphi 2

Связь TDBMemo и StringField

У меня имеется на одной из страниц TabNotebook поле DBMemo. Это поле связано с таблицей TTable (активной). Но я не могу редактировать, посылать или удалять значение этого поля. Почему? Поле в таблице текстовое, с 255 символами (A255)...

Mark Edington (Delphi R&D) признал наличие проблемы со связью элемента управления TDBMemo с TStringField в Delphi 2 и пообещал ее устранить в ближайшее время.

- Mike Orriss [000986]


Delphi 2

Ошибка в 32-битном StringGrid

Во время выполнения приложения заголовки колонок перемещаются, а сами колонки с данными нет. В 16-битной версии все работает превосходно.

- Bruce Bukovics [000989]


Исключения в Delphi

100-149 - ошибки ввода/вывода (I/O), 200-255 - фатальные ошибки согласно файлам помощи Delphi.

В Windows.pas всем кодам ошибок внешних исключительных ситуаций присвоены имена. Поищите, например

STATUS_BREAKPOINT

чтобы найти декларации констант ошибок.

Ошибки времени выполнения, расположенные в таблице с номерами ниже 100 (и несколько ошибок с номерами больше 100, но они незначительны) - ошибки DOS.

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

Код и описание ошибок, возникающий в среде DOS
Код (Hex) | Код (Dec) | Описание
00h | 0 | нет ошибки
01h | 1 | неверный номер функции
02h | 2 | файл не найден
03h | 3 | путь не найден
04h | 4 | cлишком много открытых файлов (нет свободных дескрипторов)
05h | 5 | доступ запрещен
06h | 6 | неверный дескриптор
07h | 7 | управляющий блок памяти разрушен
08h | 8 | недостаточно памяти
09h | 9 | неверный адрес блока памяти
0Ah | 10 | неверное окружение (обычно при длине > 32К)
0Bh | 11 | неверный формат
0Ch | 12 | неверный код доступа
0Dh | 13 | неверные данные
0Eh | 14 | зарезервировано
0Fh | 15 | неверное устройство (drive)
10h | 16 | попытка удаления текущей директории
11h | 17 | не то же устройство
12h | 18 | нет больше файлов
--- DOS 3.0+ ---
13h | 19 | диск имеет защиту от записи
14h | 20 | неизвестное устройство
15h | 21 | устройство не готово
16h | 22 | неизвестная команда
17h | 23 | ошибка данных (CRC)
18h | 24 | неправильный запрос длины структуры
19h | 25 | ошибка поиска
1Ah | 26 | неизвестный тип носителя (не-DOS диск)
1Bh | 27 | сектор не найден
1Ch | 28 | принтер без бумаги
1Dh | 29 | ошибка записи
1Eh | 30 | ошибка чтения
1Fh | 31 | общая ошибка (general failure)
20h | 32 | нарушение доступа (sharing violation)
21h | 33 | нарушение доступа (lock violation)
22h | 34 | ошибка смены диска (ES:DI -> media ID диска) (смотри #0981)
23h | 35 | FCB недоступно
24h | 36 | переполнение буфера общего доступа (sharing buffer)
25h | 37 | (DOS 4.0+) несовпадение кодовой страницы
26h | 38 | (DOS 4.0+) невозможно завершить действие с файлом (чтение или запись)
27h | 39 | (DOS 4.0+) недостаточно места на диске
28h-31h |  | зарезервировано
32h | 50 | сетевой запрос не поддерживается
33h | 51 | удаленный компьютер не откликается
34h | 52 | дублирование сетевого имени
35h | 53 | сетевое имя не найдено
36h | 54 | сеть занята
37h | 55 | сетевое устройство больше не существует
38h | 56 | превышен лимит команд сетевого BIOS
39h | 57 | аппаратная ошибка сетевого адаптера
3Ah | 58 | из сети получен неверный ответ
3Bh | 59 | неожиданная сетевая ошибка
3Ch | 60 | несовместимый сетевой адаптер
3Dh | 61 | полная очередь печати
3Eh | 62 | очередь не полная
3Fh | 63 | нет свободного места для печати файла
40h | 64 | сетевое имя было удалено
41h | 65 | сеть: в доступе отказано
42h | 66 | неверный тип сетевого устройства
43h | 67 | сетевое имя не найдено
44h | 68 | превышен лимит сетевого имени
45h | 69 | превышен лимит сеансов сетевого BIOS
46h | 70 | временная пауза
47h | 71 | сетевой запрос не принят
48h | 72 | сетевая печать/дисковая переадресация приостановлена
49h | 73 | программная поддержка сети не установлена (LANtastic) неверная сетевая версия
4Ah | 74 | неожиданный отказ сетевого адаптера (LANtastic) истек бюджет пользователя (account)
4Bh | 75 | (LANtastic) истек пароль
4Сh | 76 | (LANtastic) на этот раз неудачная попытка входа в сеть
4Dh | 77 | (LANtastic v3+) не хватает дискового пространства на сетевом узле
4Eh | 78 | (LANtastic v3+) нет регистрации на сетевом узле
4Fh | 79 | зарезервировано
50h | 80 | файл существует
51h | 81 | зарезервировано
52h | 82 | невозможно создать каталог
53h | 83 | ошибка на INT 24h
54h | 84 | (DOS 3.3+) слишком много переадресаций
55h | 85 | (DOS 3.3+) двойная переадресация
56h | 86 | (DOS 3.3+) неверный пароль
57h | 87 | (DOS 3.3+) неверный параметр
58h | 88 | (DOS 3.3+) ошибка сетевой записи
59h | 89 | (DOS 4.0+) функция в сети не поддерживается
5Ah | 90 | (DOS 4.0+) не установлен необходимый системный компонент
64h | 100 | (MSCDEX) неизвестная ошибка
65h | 101 | (MSCDEX) нет готовности
66h | 102 | (MSCDEX) нехватка EMS памяти
67h | 103 | (MSCDEX) не High Sierra или ISO-9660 формат
68h | 104 | (MSCDEX) открыт лоток
B0h | 176 | (MS-DOS 7.0) носитель не блокирован
B1h | 177 | (MS-DOS 7.0) носитель блокирован
B2h | 178 | (MS-DOS 7.0) не сменный носитель
B4h | 180 | (MS-DOS 7.0) переполнение счетчика блокировок
B5h | 181 | (MS-DOS 7.0) неудача запроса на извлечение носителя

[000084]


Номера ошибок

Номера ошибок
Ошибка | Сообщение об ошибке
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)

[000131]


Перехват ошибки

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := MyExcept;
end;

Procedure TForm1.MyExcept(Sender:TObject; E:Exception);
begin
If E is EDatabaseError then
MessageDlg('Перехвачено исключение', mtInformation, [mbOk], 0)
else
{ если это не та ошибка, которую вы ищете, передайте на обработку дальше }
end;

[000425]


Как зарегистрировать OCX?

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

Предположим вы создали OCX с именем "test.ocx".

Теперь его необходимо зарегистрировать в системе:

var
OCXHand: THandle;
RegFunc: TDllRegisterServer;   //добавьте OLECtl в список используемых модулей
begin
OCXHand:= LoadLibrary('c:\windows\system\test.ocx');
RegFunc:= GetProcAddress(OCXHand, 'DllRegisterServer');  //чуствительность к регистру?
if RegFunc <> 0 then ShowMessage('Ошибка!');
FreeLibrary(OCXHand);
end;

Для обратной процедуры, "отрегистрации" OCX, вам необходимо всего лишь заменить 'DllRegisterServer' на 'DllUnregisterServer'.

Также для полноты картины вы можете добавить код, извещающий пользователя о процессе регистрации, например так: "Does the file exist" (файл не найден), "Was the call to LoadLibrary successful?" (был ли вызов LoadLibrary успешным?), ...

Некоторые пояснения:

OCX - специфический форма dll, поэтому вы можете загрузить ее в память, используя знакомую уже API функцию LoadLibrary(). OCX экспортирует две функции, осуществляющие ее регистрацию и "отрегистрацию". Для получения адреса этих функций используется соответствующая функция GetProcAddress. После этого остается только вызвать необходимую функцию. И это все! После этого для успокоения души с помощью редактора регистров (regedit.exe) вы можете проверить регистрацию вашего OCX.

[000221]


COM

COM расшифровывается как "Component Object Model" - Модель Компонентных Объектов. Это стандарт, описывающий как должны работать интерфейсы класса (или объекта) -- включая такие вопросы, как, например, работа с памятью или многопоточностью, и каким образом приложения могут использовать компоненты, созданные в стандарте COM. COM является стандартом, независимым от языка программирования и (по крайней мере, как это понял я) независимым от аппаратного окружения. Первоначально стандарт был разработан, опубликован и принят фирмами Microsoft и IBM, но пока не существует технической причины для того, чтобы он не поддерживался, например, и на Sun Sparc20 под управлением операционной системы Solaris.

Вот отличительные признаки и основные механизмы функционирования COM-объекта:

  1. У него имеется "globally unique identifier" (глобальный уникальный идентификатор) -- сокращенно GUID или CLSID -- 128-битное целое число, которое, по существу, должно гарантировать уникальность COM-объекта (или интерфейса в случае CLSID) на всех компьютерах нашей планеты. Для того, чтобы воспользоваться COM-объектом, клиенту необходимо знать его GUID.
  2. Если клиенту известен GUID COM-объекта, то для создания его экземпляра можно воспользоваться стандартным API вызовом CoCreateInstance.
  3. Объект содержит по крайней мере один интерфейс с именем IUnknown. IUnknown имеет три метода: AddRef, Release и QueryInterface. AddRef и Release вызываются клиентами для управления счетчиком ссылок, в котором хранится количество используемых ссылок на объект. Как только счетчик ссылок будет равен нулю, объект будет удален из памяти.

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

OLE - "развивающийся стандарт" (который, вероятно, в нашем контексте можно назвать "перемещающий цели"), созданный для предоставления комплекса услуг (компонентам, приложениям и др.) с применением COM-ориентированных объектов.

Автоматизация OLE является отдельным OLE-сервисом, предоставляющим клиенту возможность управления отдельными компонентами. Действительно, это несколько непривычно. Компонент, которым можно управлять с помощью OLE автоматизации, называется IDispatch. IDispatch включает методы для определения поддерживаемых интерфейсом методов (извините за каламбур), их имен, типов данных, описание всех параметров и специальный "dispatch ID" для каждого метода интерфейса. Если клиент знает имя метода, то с помощью IDispatch он может узнать о нем все. Конечно, это займет какое-то время, но это работает. Конечно лучше, когда он заранее знает (например, во время компиляции) dispID и информацию о параметрах вызываемого метода для его непосредственного вызова во время выполнения программы через метод IDispatch Invoke.

Для вызовов всех методов объекта программа использует интерфейс объектов IDispatch (и/или библиотеку типов) для определения dispID и информации о параметрах, и при компиляции вставляет эту информацию в вашу программу. Это так называемое "раннее связывание", позволяющее осуществлять максимально быстрые вызовы методов COM-объектов при использовании OLE автоматизации. Вы можете также воспользоваться "поздним связыванием", когда программа для определения dispID, имени метода и пр. использует IDispatch только во время ее выполнения. Это случается при использовании объектной переменной, объявленной "как объект" ("As Object"). Позднее связывание достаточно медленное и отчасти ненадежное (поскольку во время компиляции программа не может осуществить проверку параметров), но может иногда применяться ввиду своей гибкости. [000262]


Delphi 2

Delphi 2.0 & COM объекты

...я обращался к справке MS Help, но и там я не нашел как работать с объектами COM в Delphi.

Работать с COM-объектами в Delphi очень просто, поскольку объекты Delphi имеют ту же структуру, что и объекты COM. Единственное различие заключается в том, что в определении COM имеется три метода для изменения состояния COM объекта: QueryInterface, AddRef и Release.

Теперь для того, чтобы иметь доступ к COM объекту из другого приложения или DLL, вам необходимо написать в Delphi объявление виртуального абстрактного класса, являющегося потомком IUnknown (в котором объявлены QueryInterface, AddRef и Release). В этом классе для COM объекта вы добавляете методы, объявленные в заголовочном файле C, в том же порядке следования. В этом случае вы запрашиваете интерфейс IShellLink, определенный в SHLOBJ.C и один из интерфейсов, предоставляемых Delphi 2, с помощью которого вы сможете реализовать свой собственный. Это может выглядеть приблизительно так:

type
IShellLink = class( IUnknown )
function GetPath( pszFile    : PChar ;
cchMaxPath : integer ;
pfd        : PWIN32_FIND_DATA ;
fFlags     : cardinal ) : HResult ; virtual ; stdcall ;
abstract ;
... и т.д..
end ;

Вы объявляете переменную для объекта IShellLink и вызываете метод GetPath?

Вы можете создавать экземпляр IShellLink, используя CoCreateInstance и передавая CLSID для IShellLink. Затем вы можете вызывать методы IShellLink, как, например, GetPath. Описание механизма работы может занять не одну статью, но реализованная в Delphi высокоуровневая инкапсуляция делает жизнь программиста намного легче, без необходимости залезать в столь глубокие дебри данной технологии. Особо любознательным я предлагаю преобрести "Programmer's Guide to Microsoft Windows 95", содержащую примеры (к сожалению, на C), лежащие в плоскости нашей темы.

- Mike Scott. [000908]


DCOM

О технологии DCOM. Я написал 3-звенное распределенное RDBMS-приложение, используя новые модули удаленных данных (Remote Data Modules) из поставки Delphi3. Я добавил некоторые собственные интерфейсы и методы в мой удаленный модуль данных для поддержки пользовательских SQL-запросов от клиента. (Была такая необходимость.) Все заработало просто замечательно, но самая отрадная весть - вся клиентская часть приложения представляла собой всего-лишь 2 файла! Без BDE! Без RDBMS-клиента! Без конфигурации! Классно, правда? Всего два файла - my.exe и 'dbclient.dll'.

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

Кто-нибудь еще разрабатывал DCOM-объекты? Я хотел бы здесь начать цикл статей (советов) о применении Delphi для создания распределенных приложений. В течение ближайших месяцев я должен разработать несколько распределенных приложений уровня предприятия. Для пользы дела я берусь опубликовать все ваши наработки, подсказки, хитрости и ньюансы технологии, присланные по электронной почте.

Приведу пример:

Экспорт DB-компонентов из модулей удаленных данных

После того, как Вы создали приложение с использованием пункта меню New->Remote Data Module при создании модуля данных сервера приложений, Вам необходимо экспортировать все необходимые для него TDataSet и TProviders-компоненты. Для этого щелкните на них правой кнопкой мыши и выберите пункт экспорта их Вашего модуля данных.

Добавление Ваших собственных методов в модули удаленных данных

Есть два пути решения задачи. При нажатии правой кнопки мыши в окне исходного кода, возникающего при просмотре исходников модулей удаленных данных, вызывается контекстное меню, содержащее пункт "Add to Interface". Это мини-Мастер, позволяющий создать процедуру, функцию или декларацию какого-либо свойства. Он последовательно предложит заполнить необходимые поля на нескольких экранах (каждый экран содержит поясняющую информацию). Не забывайте о том, что Вы просто не сможете ввести какие-либо данные для Ваших параметров. OLE/COM/DCOM/ActiveX/Whatever в Delphi поддерживают только некоторое подмножество типов данных. (например, тип WideString вместо типа String) Полный список поддерживаемых типов доступен в разделе 'types:type libraries' электронной справки.

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

Второй способ заключается в использовании редактора библиотеки типов (меню View->Type Library). Это лучшее решение в случае, если Вам необходимо добавить большое количество новых методов. Сначала Вы можете разместить их здесь и включить в свой код позже. При записи кода на диск, в отличие от создаваемых в Delphi заголовков обработчиков событий, редактор библиотеки типов не удалит их даже в случае, если тело метода остается пустым.

Доступ к методам из модуля удаленных данных (или другого COM-объекта)

Единственное мною обнаруженное решение состоит в использовании компонента TRemoteServer (закладка Data Access). Установите в свойствах компонента имя компьютера и имя сервера. После этого можно обратиться к любому существующему методу, например:

MyDataModule.MyRemoteServer.AppServer.MyCustomMethod( myParam,
myParam2 );

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

Проблема с добавлением Ваших собственных методов с интерфейсами в библиотеку типов.

При добавлении методов в модуль удаленных данных через новые интерфейсы, я столкнулся со странной проблемой. После создания новых интерфейсов, кодирования, сохранения, закрытия и повторного открытия проекта, Delphi иногда добавляет ключевое слово 'const' к спискам параметров новых интерфейсов. При этом Delphi -не делает- обновления списка параметров в коде модуля удаленных данных, поэтому при компиляции вновь открытого проекта компилятор ругается на противоречивые декларации метода. Затем мне приходится вручную добавлять ключевое слово 'const' к декларациям данных и определений методов модуля. После все работает как часы. Так что не забывайте про ключевое слово 'const'. По крайней мере это выработало во мне определенный рефлекс, и я "на автопилоте" добавляю его во все списки параметров моего метода.

Это может служить проблемой для методов, модифицирующих какие-либо параметры. Может DCOM это не поддерживает? Какие идеи?

[000073]


Отклик 1 - Сергей Качалов

Привет, Валь!

>Кто-нибудь еще разрабатывал DCOM-объекты?

Отчасти. Как только я за них вплотную взялся, еще с Delphi3 так тут же выяснились некоторые скверные детали:

1. DCOM не поддерживается в стандартной поставке Win95, только на NT. Для того, чтобы заставить клиентское приложение работать, надо либо доустанавливать на 95 поддержку DCOM, либо иметь у клиента NT (Ws или сервер - все равно). Насчет 98 не знаю.
2. На сервере надо устанавливать специальные права доступа с помощью утилиты Dcomcnfg.exe

Лично мне так и не удалось заставить ЭТО работать в РЕАЛЬНОЙ обстановке. т.е. не на одной машине, в качестве эксперимента (с этим все OK), а именно в распределенной системе. А у тебя получилось?

Зато все прекрасно получилось с Delphi4, только не с помощью DCOMConnection, а с помощью SocketConnection. Строго говоря, сама технология COM при этом никуда не девается, но она полностью остается на стороне сервера. У клиента действительно устанавливается только два файла, о которых ты упомянул. В качестве недостатка (относительного) - понижение уровня защиты. Все остальное остается на своих местах. Я пробовал. Более того, в качестве экстремальных испытаний я добился вполне сносной работы при соединении клиента модемом на 2400!

Существует и еще один интересный момент. Можно заставить программу работать с базой данных без BDE. Стандартными методами.
Боюсь ошибиться, еще осенью это проделывал, но саму технологию испытал - работает. Смысл в том, что в клиентской программе, работающей с базой данных, для соединения с данными используется CLientDataSet, вернее, его свойство сохранять работоспособность при временном отключении от базы данных. В качестве базы данных _временно_ используется локальный файл. Как известно, нет ничего более постоянного, чем "временное" :)
Сначала создается реальная таблица. Потом в приложении цепляешься к данным следующим образом:
TTable -> Provider -> ClientDataSet -> DataSource -> (далее по вкусу) В ClientDataSet делаешь непустым свойство FileName.
Активизируешь все это. В результате в файле, имя которого ты указал, создается рабочий буфер Ttable.
Свойство Active у ClientDataSet сбрасываешь в False.
Удаляешь из проекта TTable - больше он не нужен. (можно, собственно, и оставить - мешать не будет). С таким же успехом, вообще говоря, там может быть и TQuery.

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

[-skip(личная переписка)-]

Всего.
Сергей Качалов. [000143]


Отклик 2 - Василий Цыхмыстро

Может быть это не совсем моё дело (если так, то я конечно извиняюсь), но прочитав "Советы" (Версия 1.1.7 от 1.12.1999) по DCOM я хотел бы коё-что про это рассказать. Если это не пригодиться, то прошу прощения за навязчивость...

Когда я занялся этим вопросом, то пришёл к выводу, что:

  1. Если делать локатьную базу данных с помощью одного лишь TClientDataSet и dbclient.dll, то в этой базе данных будут храниться не только данные как таковые, но и их эволюция, т.е. все изменения, происходящие с базой, притом точно в той же последовательности, в какой они были сделаны (удалённые записи и старый вид модифицированных). Следовательно, эта база представляет собой последовательный список изменений... И последовательным вызовом UndoLastChange можно вернуться к самому началу - пустой базе. Размер этой базы данных пропорционален количеству изменений, и, поэтому, её лучше не использовать для каких-либо проектов, кроме самых маленьких...
  2. Когда же я вызывал CloneCursor в надежде, что лишняя информация отбросится, то... зря я это делал.

    От другого читателя:

    Все это правильно, однако открываем Help и читаем:

    >procedure MergeChangeLog;

>Description
>Call MergeChangeLog to merge changes in the change log into the actual data for the
>dataset, effectively creating a new data baseline. Existing values for which changes
>exist are overwritten.

>Note
>Ordinarily, applications need not call this method. It is called automatically by
>ApplyUpdates as part of the updating process.
    Все, проблема избыточных данных решена.

    Vadim Petrov

  3. Настроить DCOM под Windows 98 можно - было предусмотренно, но главным недостатком в этом случае является то, что для подключения к приложению DCOM-серверу необходимо, чтобы последний был запущен. (Это из-за того, что при настройке в Dcomcnfg сильно с настройками не разбежишься - выбор мал).
  4. Под Windows NT (проверенно под 4 версию) DCOM технология работает лучше, но надо настроить нормально для правильной работы. Эксперементально проверены на работоспособность следующие настройки:
      Authentication Level        -        Connect
  Impersonation Level         -        Identify
  Identify                    -        The interactive user
Последняя, в часности, позволила запускаться приложению-серверу не как службе (я приложение-сервер не как службу писал)...

Очень буду рад, если это поможет ещё кому-то, кроме меня...

С уважением, Chronic
(Василий Цыхмыстро) [000507]


Delphi 1

Получение данных из Program Manager через DDE

Установите соединение DDEClientConv с сервером и установите обоим DdeTopic в 'ProgMan'. Вызовите RequestData и передайте 'Groups' как элемент (item); обратно вы получите список имен групп. Вызовите RequestData с одним из имен групп и вы получите детальную информцию о группе. Вероятно дальше вы захотите передать полученные данные в ListBox, т.к. сразу можно увидеть что мы имеем и как затем это можно обработать, например:

VAR P : PChar;
...
P := DdeClientConv1.RequestData('Groups');
ListBox1.Items.SetText(P);
StrDispose(P);
...
WITH ListBox1 DO
P := DdeClientConv1.RequestData(Items[ItemIndex]);
ListBox2.Items.SetText(P);
StrDispose(P);
...

- Neil [000486]


OLE тестер

Это ОЧЕНЬ простой тест, который я добавил к своей программе для проверки работоспособности OLE. Меня попросили добавить к моей программе поддержку OLE и мне пришлось изобретать способ проверки работоспособности моего OLE-сервера.

В данном примере в момент создания формы создается OLE-объект и после нажатия на какую-либо из кнопок вызывается определенная процедура OLE-сервера.

unit oletestu;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
ttsesed : variant;
end;

var
Form1: TForm1;

implementation
uses oleauto;
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
ttsesed := createoleobject('ttdewed.ttsesole');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ttsesed.openeditfile;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ttsesed.appshow;
end;

end.
[000189]


Delphi 1

Динамическое OLE

Некоторое время тому назад вы задавали вопрос по поводу динамического OLE без создания диалогового окна для просмотра файла. Я таки добился этого и вот код...

Uses
..., BOleDefs, ...

procedure TPreview.previewOLEFile(fileName: string);
var
Info: ^BOleInitInfo;
cString: array[0..80] of char;
begin

Screen.Cursor := crHourGlass;
try
GetMem(Info,sizeof(BoleInitInfo));

Info^.How := BOLE_EMBED;
Info^.Where := BOLE_FILE;
Info^.pContainer := nil;
Info^.hIcon := 0;
Info^.Storage := nil;

StrPCopy(cString,fileName);
Info^.Path := cString;

oleDocument.PInitInfo := Info;
ReleaseOLEInitInfo(Info);   { данная функция освобождает (getmem) память ! }
oleDocument.Visible := True;

finally
Screen.Cursor := crDefault;

end;
end;

[000510]


Delphi 1

Чтение сложных OLE-документов

Не используйте для этого компонент TOleContainer. Создавая приложение с возможностью доступа к файлам OLE Structured Storage (стуктурное хранилище), реально необходима только пара вызовов OLE API, и 5-6 вызовов API для доступа к функциям-членам интерфейсов IStorage, IRootStorage и IStream. Я подозреваю, что функция-член TOleContainer IStorage является указателем на корневое хранилище файла Structured Storage, создаваемого функциями-членами LoadFromFile/SaveToFile TOleContainer.

Необходимые функции API:

StgOpenStorage
StgIsStorageFile

Если у вас есть OLE 2.01 SDK, вы можете найти определения там.

Будьте внимательны, при переносе заголовочных файлов C++ из OLE SDK в Delphi, Borland допустил несколько ошибок. Одна из ошибок при создании апплета обернулась мне тремя бессонными ночами. Вот правильное определение IStorage:

MyIStorage = class(IUnknown)
function CreateStream(const pwcsName: PChar; grfMode: Longint; reserved1: Longint;
reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract;
function OpenStream(const pwcsName: PChar; reserved1: Pointer; grfMode: Longint;
reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract;
function CreateStorage(const pwcsName: PChar; grfMode: Longint;
reserved1: Longint; reserved2: Longint; var ppstg: MyIStorage): HResult;
virtual; cdecl; export; abstract;
function OpenStorage(const pwcsName: PChar; pstgPriority: MyIStorage;
grfMode: Longint; snbExclude: PStr; reserved: Longint;
var ppstg: MyIStorage): HResult; virtual; cdecl; export; abstract;
function CopyTo(ciidExclude: Longint; const rgiidExclude: IID;
var snbExclude: PStr; pstgDest: MyIStorage): HResult; virtual; cdecl; export; abstract;
function MoveElementTo(const lpszName: PChar; pstgDest: MyIStorage;
const lpszNewName: PChar; grfFlags: Longint): HResult; virtual; cdecl; export; abstract;
function Commit(grfCommitFlags: Longint): HResult; virtual; cdecl; export; abstract;
function Revert: HResult; virtual; cdecl; export; abstract;
function EnumElements(reserved1: Longint; reserved2: Pointer; reserved3: Longint;
var ppenm: IEnumStatStg): HResult; virtual; cdecl; export; abstract;
function DestroyElement(const pwcsName: PChar): HResult; virtual; cdecl; export; abstract;
function RenameElement(const pwcsOldName: PChar;
const pwcsNewName: PChar): HResult; virtual; cdecl; export; abstract;
function SetElementTimes(const lpszName: PChar; const pctime: TFileTime;
const patime: TFileTime; const pmtime: TFileTime): HResult;
virtual; cdecl; export; abstract;
function SetClass(const clsid: IID): HResult; virtual; cdecl; export; abstract;
function SetStateBits(grfStateBits: Longint; grfMask: Longint): HResult;
virtual; cdecl; export; abstract;
function Stat(var pstatstg: TStatStg; grfStatFlag: Longint): HResult;
virtual; cdecl; export; abstract;
end;

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

Надеюсь, это поможет.

John

-John Lam [000577]


Delphi 2

Application.Initialize

Метод Application.Initialize выполняет соответствующие задачи инициализации OLE Automation, например, регистрацию или "отрегистрацию" классов OLE Automation в системных регистрах, или завершение приложения, если оно было запущено с единственной целью - регистрацией. По своей сути, если приложение не является OLE Automation сервером, то такой вызов будет являться пустым оператором, и, если вы не создаете OLE Automation сервер, то можно спокойно удалить строку "Application.Initialize;" из исходного кода вашего проекта. Следовательно, если вы не добавляете функциональность OLE Automation сервера к 16-битному проекту, то при перекомпиляции старых проектов нет необходимости добавлять данный вызов.

Тут может помочь директива компилятора $IFDEF WIN32?

Да, вы можете сделать так:

{$IFDEF WIN32}
Application.Initialize; {$ENDIF}

- Anders Hejlsberg [000882]


Delphi 2

Интерфейс 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:

SmtOleLink(VarToInterface(MyObject), 16, 0);

Функция "VarToInterface" (определенная в модуле OleAuto) извлекает указатель IDispatch из Variant (или возбуждает исключение, если Variant не содержит ссылки на объект OLE Automation).

Это должно сработать.

- Anders Hejlsberg [000885]


Delphi 2

Вызов 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);
}

[000075]


Общий доступ к памяти, распределенной DLL

Общий доступ к области отображения файлов (Sharing Memory Mapped Files)... Проверьте нижеследующий код:

var
HMapping: THandle;
PMapData: Pointer;

const
MAPFILESIZE = 1000;

procedure OpenMap;
var
llInit: Boolean;
lInt: Integer;
begin
HMapping := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, MAPFILESIZE, pchar('ИМЯ ОБЛАСТИ ОТОБРАЖЕНИЯ'));
// Проверка наличия
llInit := (GetLastError() <> ERROR_ALREADY_EXISTS);
if (hMapping = 0) then begin
ShowMessage('Невозможно создать объект отображения файла');
Application.Terminate;
exit;
end;
PMapData := MapViewOfFile(HMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if PMapData = nil then begin
CloseHandle(HMapping);
ShowMessage('Невозможно отобразить блок памяти');
Application.Terminate;
exit;
end;
if (llInit) then begin
// Если объект отображения создан, инициализируем блок символами #0
memset(PMapData, #0, MAPFILESIZE);
end;
end;

procedure CloseMap;
begin
if PMapData <> nil then begin
UnMapViewOfFile(PMapData);
end;
if HMapping <> 0 then begin
CloseHandle(HMapping);
end;
end;

Таким образом любые два или более приложения или DLL могут получить указатели к одному и тому же блоку памяти. В данном примере PMapData указывает на 1000-байтный буфер, инициализированный вначале символами #0. Однако существует одна потенциальная проблема - синхронизация доступа к памяти. Решить эту проблему можно с помощью мьютексов. Вот пример их использования:

{ Вызовите LockMap перед записью (и чтением?) объекта отображения файла. Не забывайте после каждого обновления немедленно вызывать UnlockMap. }

var
HMapMutex: THandle;

const
REQUEST_TIMEOUT = 1000;

function LockMap:Boolean;
begin
Result := true;
HMapMutex := CreateMutex(nil, false, pchar('ИМЯ ВАШЕГО МЬЮТЕКСА'));
if HMixMutex = 0 then begin
ShowMessage('Не могу создать мьютекс');
Result := false;
end else begin
if WaitForSingleObject(HMapMutex,REQUEST_TIMEOUT) = WAIT_FAILED then begin
// время ожидания
ShowMessage('Невозможно заблокировать объект отображения файла');
Result := false;
end;
end;
end;

procedure UnlockMap;
begin
ReleaseMutex(HMixMutex);
CloseHandle(HMixMutex);
end;

[000272]


Delphi 1

Сегменты данных DLL

Я надеюсь что у вас имеются эти две небольшие строки в главных модулях ваших DLL (если он не содержит обработку прерываний):

(* делаем фиксированные сегменты данных DLL перемещаемыми *)
GlobalPageUnlock( DSeg );
GlobalReAlloc(DSeg, 0, GMEM_MODIFY or GMEM_MOVEABLE);

Если вы не будете размещать сегменты данных DLL в нижней части памяти DOS, то вы сможете сэкономить весьма скудные (и важные!) ресурсы...

- Peter Below [000808]


Delphi 1

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. [000443]


Delphi 2

FTP4W32.DLL и Delphi 2.0

Вот модуль, который у меня работает. Сейчас я работаю над компонентом, инкапсулирующим данную DLL. Если кто хочет потестировать данный код, направьте мне письмо по адресу bstowers@pobox.com и я вышлю Вам демонстрационный проект.

unit FTP4W;
{ Обновлено в феврале 1997 Брадом Стоверсом (Brad Stowers               }
{ bstowers@pobox.com) для использования с FTP4W v2.6.                   }
{ Добавлены новые функции, исправлены некоторые ошибки, включен         }
{ "cleaner (стиратель)" и переделано для работы c Delphi 2. Т.к. я      }
{ уже не использую Delphi 1, существует большая вероятность, что данный }
{ модуль не сможет быть откомпилен в Delphi 1, например, из-за наличия  }
{ директивы 'stdcall'. В паскалевском файле-оболочке 'UseFTP4W.pas'     }
{ Delphi 1 удалил все директивы 'stdcall'. Данный код основан на на     }
{ разработках следующих людей:                                          }

{ Barbara Tikart Polarwolf Hard & Software, D-63906 Erlenbach am Main   }
{ и AStA Uni Konstanz (AStA = Allgemeiner Studierenden Ausschuss)       }
{ eMail для Andreas.Tikart@uni-konstanz.de или AStA@uni-konstanz.de     }
{ Требования к FTP: 'FTP4W' версии 2.2g или выше                        }
{ Предназначено для свободного распространения                          }
{ Последняя версия модуля доступна по адресу                            }
{ http://www.uni-konstanz.de/studis/asta/software/index.html            }

interface

uses Windows, WinSock, SysUtils;

const
FTP4W_Loaded: boolean = FALSE;        { Проверка загруженности DLL        }
FTP4W_RightVersion: boolean = FALSE;  { Проверка корректности версии DLL. }

const
{ Режим передачи. }
TYPE_A       = 'A'; { ASCII }
TYPE_I       = 'I'; { Изображение (Двоичный) }
TYPE_L8      = 'L'; { Локальная 8 }
TYPE_DEFAULT = #0;  { Значение по умолчанию для сервера. }

{ Зарегистрированные действия пользователя.... Какими они могут быть? }
FTP_STORE_ON_SERVER  = 65;
FTP_APPEND_ON_SERVER = 87;
FTP_GET_FROM_SERVER  = 223;

{ Возможный тип брэндмауэра. }
FTP4W_FWSITE          = 100;
FTP4W_FWPROXY         = 103;
FTP4W_FWUSERWITHLOGON = 106;
FTP4W_FWUSERNOLOGON   = 109;

{ Коды, возвращаемые FTP-функциями }
FTPERR_OK            = 0; { успешное завершение функции                              }
FTPERR_ENTERPASSWORD = 1; { требуется пароль для userid                              }
FTPERR_ENTERACCOUNT  = 2; { user/pass OK, но требуется бюджет пользователя (account) }
FTPERR_ACCOUNTNEEDED = 2; { user/pass OK, но требуется бюджет пользователя (account) }
FTPERR_RESTARTOK     = 3; { успешная команда перезапуска                             }
FTPERR_ENDOFDATA     = 4; { сервер закончил передачу данных                          }
FTPERR_CANCELBYUSER = -1; { передача данных прервана пользователем (FtpAbort)        }

{ Ошибки пользователя или программиста }
FTPERR_INVALIDPARAMETER    = 1000; { Ошибка в параметрах }
FTPERR_SESSIONUSED         = 1001; { Пользователь уже имеет сеанс FTP }
FTPERR_NOTINITIALIZED      = 1002; { Отсутствует инициализация (не вызван FtpInit) }
FTPERR_NOTCONNECTED        = 1003; { Пользователь не подключен к серверу }
FTPERR_CANTOPENFILE        = 1004; { невозможно открыть определенный файл }
FTPERR_CANTWRITE           = 1005; { невозможно передать файл (переполнен диск?) }
FTPERR_NOACTIVESESSION     = 1006; { FtpRelease без FtpInit }
FTPERR_STILLCONNECTED      = 1007; { FtpRelease без какого-либо Close }
FTPERR_SERVERCANTEXECUTE   = 1008; { неудачное действие с файлом }
FTPERR_LOGINREFUSED        = 1009; { Сервер отверг usrid/passwd }
FTPERR_NOREMOTEFILE        = 1010; { сервер не может открыть файл }
FTPERR_TRANSFERREFUSED     = 1011; { Сервер отклонил передачу }
FTPERR_WINSOCKNOTUSABLE    = 1012; { Требуется winsock.DLL версии 1.1 }
FTPERR_CANTCLOSE           = 1013; { неудачное закрытие (осуществляетcя cmd) }
FTPERR_FILELOCKED          = 1014; { ошибка удаления файла (FtpDelete) }
FTPERR_FWLOGINREFUSED      = 1015; { Брэндмауэр отверг usrid/passwd }
FTPERR_ASYNCMODE           = 1016; { FtpMGet только в синхронном режиме }

{ Ошибки TCP }
FTPERR_UNKNOWNHOST         = 2001; { сервер по адресу не найден }
FTPERR_NOREPLY             = 2002; { сервер не отвечает на запрос }
FTPERR_CANTCONNECT         = 2003; { Ошибка во время связи }
FTPERR_CONNECTREJECTED     = 2004; { сервер не поддерживает FTP }
FTPERR_SENDREFUSED         = 2005; { невозможна передача данных (сеть недоступна) }
FTPERR_DATACONNECTION      = 2006; { ошибка связи с портом данных }
FTPERR_TIMEOUT             = 2007; { время ожидания истекло }
FTPERR_FWCANTCONNECT       = 2008; { Ошибка с брандмауэром в течение сеанса }
FTPERR_FWCONNECTREJECTED   = 2009; { Брэндмауэр не поддерживает FTP-соединений }

{ Ошибки FTP }
FTPERR_UNEXPECTEDANSWER    = 3001; { истек срок ожидания ответа }
FTPERR_CANNOTCHANGETYPE    = 3002; { сервер отверг команду TYPE }
FTPERR_CMDNOTIMPLEMENTED   = 3003; { сервер признал, но не смог осуществить команду }
FTPERR_PWDBADFMT           = 3004; { Пароль опознан, но команды не проходят }
FTPERR_PASVCMDNOTIMPL      = 3005; { Сервер не поддерживает пассивный режим }

{ Ошибки ресурсов }
FTPERR_CANTCREATEWINDOW    = 5002; { Недостаточно свободных ресурсов }
FTPERR_INSMEMORY           = 5003; { Недостаточная куча памяти }
FTPERR_CANTCREATESOCKET    = 5004; { нет свободного гнезда (socket) }
FTPERR_CANTBINDSOCKET      = 5005; { Неудача связи (bind) }
FTPERR_SYSTUNKNOWN         = 5006; { сервер отсутствует в списке }

{ Внутренние структуры данных FTP4W. Но это Вам вряд ли понадобится. }
const
FTP_DATABUFFER = 4096; { хорошая величина для X25/Ethernet/Token Ring}

type
PFtp_FtpData = ^TFtp_FtpData;
TFtp_FtpData = packed record
ctrl_socket: TSocket;             { управляющий поток    init
INVALID_SOCKET }
data_socket: TSocket;             { поток данных         init
INVALID_SOCKET }
cType: Char;                      { тип (ASCII/двоичный) init TYPE_A
}
bVerbose: Bool;                   { режим избыточности   init FALSE
}
bPassif: Bool;                    { VRAI -> пассивный режим
}
nPort: u_short;                   { порт связи           init
FTP_DEFPORT    }
nTimeOut: u_int;                  { TimeOut в секундах   init
FTP_DEFTIMEOUT }
hLogFile: HFile;                  { Журнальный файл
}
szInBuf: Array [0..2047] of Char; { входной буфер
}
saSockAddr: TSockAddrIn;          { никогда не используется
}
saAcceptAddr: TSockAddrIn;        { никогда не используется
}
end; { TFtp_FtpData }

PFtp_FileTrf = ^TFtp_FileTrf;
TFtp_FileTrf = packed record
hf: HFile;          { дескриптор передаваемого файла                                   }
nCount: uint;       { число записей/считываний блоков файла                            }
nAsyncAlone: uint;  { пауза каждого N-го кадра в ассинхронном режиме (по умолчанию 40) }
nAsyncMulti: uint;  { Возможное количество FTP-сеансов (по умолчанию 10)               }
nDelay: uint;       { время паузы в миллисекундах                                      }
bAborted: Bool;     { передача данных была отменена                                    }
szBuf : Array [0..FTP_DataBuffer-1] Of Char; { Буфер данных                            }
bNotify: Bool;      { приложение получает сообщение с каждым пакетом данных            }
bAsyncMode: Bool;   { синхронный или асинхронный режим                                 }
lPos: LongInt;      { Передано байтов                                                  }
lTotal: LongInt;    { должно быть передано байтов                                      }
end; { TFtp_FileTrf }

PFtp_Msg = ^TFtp_Msg;
TFtp_MSG = packed record
hParentWnd: hWnd;        { окно, которому предназначено сообщение }
nCompletedMessage: uint; { сообщение, посланное в конце функции   }
end; { TFtp_Msg }

PFtp_Verbose = ^TFtp_Verbose;
TFtp_Verbose = packed record
hVerboseWnd: hWnd;  { окно, которому предназначено сообщение                  }
nVerboseMsg: uint;  { сообщение, посылающееся каждый раз при получении строки }
end; { TFtp_Verbose }

PFtp_ProcData = ^TFtp_ProcData;
TFtp_ProcData = packed record
{ Данные задачи }
hTask: HTask;              { Идентификатор задачи                       }
hFtpWindow: hWnd;          { Дескриптор собственного (внутреннего) окна }
hParentWnd: hWnd;          { Дескриптор функции FtpInit                 }
hInstance: HInst;          { Экземпляр задачи                           }
bRelease:  Bool;           { Для вызова FtpRelease                      }
{ Информация о сообщении }
MSG: TFtp_Msg;
VMSG: TFtp_Verbose;
{ Информация о файле }
FileTrf: TFtp_FileTrf;
{Ftp-информация}
Ftp: TFtp_FtpData;
{Список связей}
Next,
Prev: PFtp_ProcData;
end; { TFtp_ProcData }

{ Тип функции обратной связи FtpMGet. }
TFtpMGetCallback = Function (szRemFile, szLocalFile: PChar; Rc: integer):
bool; stdcall;

{ FTP4W-функции }

var
{ Вспомогательные функции }
FtpDataPtr:     function: PFtp_ProcData; stdcall;
FtpBufferPtr:   function: PChar; stdcall;
FtpErrorString: function(Rc: integer): PChar; stdcall;
Ftp4wVer:       function(szVerStr: PChar; nStrSize: integer): Integer;
stdcall;

{ Изменение параметров по умолчанию }
FtpSetVerboseMode:       function(bVerboseMode: bool; hWindow: hWnd;
wMsg: UINT): Integer; stdcall;
FtpBytesTransferred:     function: LongInt; stdcall;
FtpBytesToBeTransferred: function: LongInt; stdcall;
FtpSetDefaultTimeOut:    procedure(nTo_in_sec: Integer); stdcall;
FtpSetDefaultPort:       procedure(nDefPort: Integer); stdcall;
FtpSetAsynchronousMode:  procedure; stdcall;
FtpSetSynchronousMode:   procedure; stdcall;
FtpIsAsynchronousMode:   function: Bool; stdcall;
FtpSetNewDelay:          procedure(X: Integer); stdcall;
FtpSetNewSlices:         procedure(X, Y: Integer); stdcall;
FtpSetPassiveMode:       procedure(bPassive: Bool); stdcall;
FtpLogTo:                procedure(hLogFile: HFile); stdcall;

{ Функции инициализации }
FtpRelease: function: Integer; stdcall;
FtpInit:    function(hWindow: hWnd): Integer; stdcall;
FtpFlush:   function: Integer; stdcall;

{ Соединение }
FtpLogin:           function(Host, User, Password: PChar;
hWindow: hWnd; wMSG: UINT): Integer;
stdcall;
FtpOpenConnection:  function(Host: PChar): Integer; stdcall;
FtpCloseConnection: function: Integer; stdcall;
FtpLocalClose:      function: Integer; stdcall;

{ Аутентификация }
FtpSendUserName: function(UserName: PChar): Integer; stdcall;
FtpSendPasswd:   function(Passwd: PChar): Integer; stdcall;
FtpSendAccount:  function(Acct: PChar): integer; stdcall;

{ Команды }
FtpHelp:       function(Arg, Buf: PChar; BufSize: UINT): Integer;
stdcall;
FtpDeleteFile: function(szRemoteFile: PChar): Integer; stdcall;
FtpRenameFile: function(szFrom, szTo: PChar): Integer; stdcall;
FtpQuote:      function(Cmd, ReplyBuf: PChar; BufSize: UINT): Integer;
stdcall;
FtpSyst:       function(var szSystemStr: PChar): Integer; stdcall;
FtpSetType:    function(cType: char): Integer; stdcall;
FtpCWD:        function(Path: PChar): Integer; stdcall;
FtpCDUP:       function: Integer; stdcall;
FtpPWD:        function(szBuf: PChar; uBufSize: UINT): Integer; stdcall;
FtpMKD:        function(szPath, szFullDir: PChar; uBufSize: UINT):
Integer; stdcall;
FtpRMD:        function(szPath: PChar): Integer; stdcall;

{ передача файла }
FtpAbort:              function: Integer; stdcall;
FtpSendFile:           function(Local, Remote: PChar; cType: char;
Notify: Bool;
hWindow: hWnd; wMSG: UINT): Integer;
stdcall;
FtpAppendToRemoteFile: function(Local, Remote: PChar; cType: char;
Notify: Bool;
hWindow: hWnd; wMSG: UINT): Integer;
stdcall;
FtpRecvFile:           function(Remote, Lcl: PChar; cType: char; Notify:
Bool;
hWindow: hWnd; wMSG: UINT): Integer;
stdcall;
FtpAppendToLocalFile:  function(Remote, Lcl: PChar; cType: char; Notify:
Bool;
hWindow: hWnd; wMSG: UINT): Integer;
stdcall;
FtpGetFileSize:        function: DWORD; stdcall;
FtpMGet:               function(szFilter: PChar; cType: char; bNotify:
bool;
Callback: TFtpMGetCallback): integer;
stdcall;
FtpRestart:            function(ByteCount: longint): integer; stdcall;
FtpRestartSendFile:    function(hLocal: HFile; szRemote: PChar; cType:
char;
bNotify: bool; ByteCount: Longint;
hWindow: hWnd; wMsg: UINT): integer;
stdcall;
FtpRestartRecvFile:    function(szRemote: PChar; hLocal: HFile; cType:
char;
bNotify: bool; ByteCount: Longint;
hWindow: hWnd; wMsg: UINT): integer;
stdcall;

{ Каталог }
FtpDir: function (Def, LocalFile: PChar; LongDir: Bool;
hWindow: hWnd; wMSG: UINT): Integer; stdcall;

{ Дополнительно }
FtpOpenDataConnection:        function(szRemote: pchar; nAction: integer;
cType: char): integer; stdcall;
FtpRecvThroughDataConnection: function(szBuf: Pchar;
var BufSize: UINT): integer;
stdcall;
FtpSendThroughDataConnection: function(szBuf: PChar; BufSize: UINT):
integer; stdcall;
FtpCloseDataConnection:       function: integer; stdcall;

{ Брэндмауэр }
FtpFirewallLogin: function (szFWHost, szFWUser, szFWPass, szRemHost,
szRemUser,
szRemPass: PChar; nFirewallType: integer;
hParentWnd: hWnd; wMsg: UINT): integer;
stdcall;

{ Прочее }
InitFtpGetAnswerCode: function: integer; stdcall;

implementation

const
ftp4wdll = 'FTP4W32.dll'; { Имя DLL-файла }

var
hFtp4W: THandle; { Дескриптор DLL }

{ Загрузка DLL и получение адресов всех процедур. }
function LoadFtp4WDLL: boolean;
var
OldMode: UINT;
begin
if hFtp4W <> 0 then
FreeLibrary (hFtp4W);
OldMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); { Если DLL не грузится,
запрещаем вывод системных сообщений. }
hFtp4W := LoadLibrary (ftp4wdll);
Result := hFtp4W <> 0;
SetErrorMode(OldMode);
if not Result then exit;

{ Получаем адреса всех функций }
@FtpDataPtr :=                   GetProcAddress(hFtp4W, 'FtpDataPtr');
@FtpBufferPtr :=                 GetProcAddress(hFtp4W, 'FtpBufferPtr');
@FtpErrorString :=               GetProcAddress(hFtp4W, 'FtpErrorString');
@Ftp4wVer :=                     GetProcAddress(hFtp4W, 'Ftp4wVer');
@FtpSetVerboseMode :=            GetProcAddress(hFtp4W, 'FtpSetVerboseMode');
@FtpBytesTransferred :=          GetProcAddress(hFtp4W, 'FtpBytesTransferred');
@FtpBytesToBeTransferred :=      GetProcAddress(hFtp4W, 'FtpBytesToBeTransferred');
@FtpSetDefaultTimeOut :=         GetProcAddress(hFtp4W, 'FtpSetDefaultTimeOut');
@FtpSetDefaultPort :=            GetProcAddress(hFtp4W, 'FtpSetDefaultPort');
@FtpSetAsynchronousMode :=       GetProcAddress(hFtp4W, 'FtpSetAsynchronousMode');
@FtpSetSynchronousMode :=        GetProcAddress(hFtp4W, 'FtpSetSynchronousMode');
@FtpIsAsynchronousMode :=        GetProcAddress(hFtp4W,
'FtpIsAsynchronousMode');
@FtpSetNewDelay :=               GetProcAddress(hFtp4W,
'FtpSetNewDelay');
@FtpSetNewSlices :=              GetProcAddress(hFtp4W,
'FtpSetNewSlices');
@FtpSetPassiveMode :=            GetProcAddress(hFtp4W,
'FtpSetPassiveMode');
@FtpLogTo :=                     GetProcAddress(hFtp4W, 'FtpLogTo');
@FtpRelease :=                   GetProcAddress(hFtp4W, 'FtpRelease');
@FtpInit :=                      GetProcAddress(hFtp4W, 'FtpInit');
@FtpFlush :=                     GetProcAddress(hFtp4W, 'FtpFlush');
@FtpLogin :=                     GetProcAddress(hFtp4W, 'FtpLogin');
@FtpOpenConnection :=            GetProcAddress(hFtp4W,
'FtpOpenConnection');
@FtpCloseConnection :=           GetProcAddress(hFtp4W,
'FtpCloseConnection');
>@FtpLocalClose :=               GetProcAddress(hFtp4W, 'FtpLocalClose');
@FtpSendUserName :=              GetProcAddress(hFtp4W,
'FtpSendUserName');
@FtpSendPasswd :=                GetProcAddress(hFtp4W, 'FtpSendPasswd');
@FtpSendAccount :=               GetProcAddress(hFtp4W,
'FtpSendAccount');
@FtpHelp :=                      GetProcAddress(hFtp4W, 'FtpHelp');
@FtpDeleteFile :=                GetProcAddress(hFtp4W, 'FtpDeleteFile');
@FtpRenameFile :=                GetProcAddress(hFtp4W, 'FtpRenameFile');
@FtpQuote :=                     GetProcAddress(hFtp4W, 'FtpQuote');
@FtpSyst :=                      GetProcAddress(hFtp4W, 'FtpSyst');
@FtpSetType :=                   GetProcAddress(hFtp4W, 'FtpSetType');
@FtpCWD :=                       GetProcAddress(hFtp4W, 'FtpCWD');
@FtpCDUP :=                      GetProcAddress(hFtp4W, 'FtpCDUP');
@FtpPWD :=                       GetProcAddress(hFtp4W, 'FtpPWD');
@FtpMKD :=                       GetProcAddress(hFtp4W, 'FtpMKD');
@FtpRMD :=                       GetProcAddress(hFtp4W, 'FtpRMD');
@FtpAbort :=                     GetProcAddress(hFtp4W, 'FtpAbort');
@FtpSendFile :=                  GetProcAddress(hFtp4W, 'FtpSendFile');
@FtpAppendToRemoteFile :=        GetProcAddress(hFtp4W,
'FtpAppendToRemoteFile');
@FtpRecvFile :=                  GetProcAddress(hFtp4W, 'FtpRecvFile');
@FtpAppendToLocalFile :=         GetProcAddress(hFtp4W,
'FtpAppendToLocalFile');
@FtpGetFileSize :=               GetProcAddress(hFtp4W,
'FtpGetFileSize');
@FtpMGet :=                      GetProcAddress(hFtp4W, 'FtpMGet');
@FtpRestart :=                   GetProcAddress(hFtp4W, 'FtpRestart');
@FtpRestartSendFile :=           GetProcAddress(hFtp4W,
'FtpRestartSendFile');
@FtpRestartRecvFile :=           GetProcAddress(hFtp4W,
'FtpRestartRecvFile');
@FtpDir :=                       GetProcAddress(hFtp4W, 'FtpDir');
@FtpOpenDataConnection :=        GetProcAddress(hFtp4W,
'FtpOpenDataConnection');
@FtpRecvThroughDataConnection := GetProcAddress(hFtp4W,
'FtpRecvThroughDataConnection');
@FtpSendThroughDataConnection := GetProcAddress(hFtp4W,
'FtpSendThroughDataConnection');
@FtpCloseDataConnection :=       GetProcAddress(hFtp4W,
'FtpCloseDataConnection');
@FtpFirewallLogin :=             GetProcAddress(hFtp4W,
'FtpFirewallLogin');
@InitFtpGetAnswerCode :=         GetProcAddress(hFtp4W,
'InitFtpGetAnswerCode');
end;

{ Вызов процедуры при завершении модуля, т.е. при закрытии приложения. }
procedure MyExitProc; far;
begin
if hFtp4W <> 0 then begin
{ Необходимо убедиться что все закрыто и FTP4W выгружена из памяти. }
FtpAbort;
FtpFlush;
FtpCloseConnection;
FtpLocalClose;
FTPRelease;
{ Выгружаем DLL. }
FreeLibrary(hFtp4W)
end;
end;

var
VerInfo: array[0..100] of char;
FVer: integer;
Begin
hFtp4W := 0;
AddExitProc(MyExitProc);
FTP4W_Loaded := LoadFtp4WDLL;
if FTP4W_Loaded then begin
{ Проверка корректности версии DLL. }
if @Ftp4wVer = NIL then
FVer := 0
else
FVer := Ftp4wVer(VerInfo, sizeof(VerInfo));
FTP4W_RightVersion := not ((HiByte(FVer) < 2) or ((HiByte(FVer) = 2)
and (LoByte(FVer) < 96)));
end;
end.

[000082]


Delphi 1

Пример обратного вызова DLL

Обратный вызов (callback) для NotifyRegister должен находиться в DLL. Вам не нужен MakeProcInstance, просто добавьте "export" к объявлению функции. Нижеследующий код является простым примером DLL для Delphi. Вы должны запустить все тесты вне Delphi или же ваша программа не получит никаких уведомлений (notifications). Все это выглядит похожим на Delphi, зарегистрировавшей перехват с Toolhelp...

Library Lib1;

Uses WinTypes, Messages, WinProcs, Toolhelp;

Const
WM_NOTIFY = WM_USER+$100;

Var
targetHWnd: HWnd;

Function HookProc( wID: Word; dwData: LongInt ): Bool; export;
Begin
PostMessage( targetHWnd, WM_NOTIFY, wID, dwData );
Result := False
End;

Procedure InstallHook( notifyWindow: HWnd ); export;
Begin
If targetHWnd = 0 Then Begin
If not NotifyRegister( 0, HookProc, NF_NORMAL )
Then Begin
MessageBox( notifyWindow, 'Неудача NotifyRegister!',
'Ошибка!', MB_OK+MB_ICONSTOP );
End
Else Begin
targetHWnd:= notifyWindow;
End;
End;
End;

Procedure UnInstallHook; export;
Begin
If targetHWnd <> 0 Then Begin
NotifyUnregister( 0 );
targetHWnd := 0;
End;
End;

exports
InstallHook,
UnInstallHook;

begin
targetHWnd:= 0; end.

[000504]


Delphi 1

Динамическое использование DLL

...возможно ли заставить Delphi осуществлять только линковку ссылок на необходимые приложению DLL-функции с помощью директив компилятора или чего-то подобного? Я могу с ними динамически связаться с помощью GetProcAddress или функций линковки, но я был бы счастлив если была бы альтернатива попроще. (стилистика авторская - В.О.)

Нет, даже в вашем случае вы должны использовать динамическое связывание...

Часто кажется, что проще написать в модуле явное импортирование функций, чем использовать их динамическое связывание. Тем не менее, основное преимущество динамически загружаемых DLL в том, что ваше приложение может быть загружено и быть работоспособным и в случае отсутствия DLL, при условии, что приложение может к этому "приспособиться". Например, если если вы реализовали в своей DLL трехмерное представление вашего объекта, но DLL не была найдена (при попытке загрузить ее динамически), то приложение также будет работать, но объекты будут представлены в обычном, двумерном виде. Если DLL, о которой идет речь, будет связана статически, Windows откажется выполнять приложение (с претензией, что ваша 3D.DLL не была обнаружена), чему пользователь будет "неслыханно рад". Другое преимущество явного импорта в модуле в том, что приложение будет загружаться быстрее, поскольку динамически подгружаемые DLL будут загружены впоследствии, когда они действительно понадобятся.

Проследим, что получается, если вы используете в модуле явный импорт DLL или в вашем коде вы объявляете функцию DLL с внешним 'DLLNAME'. В этом случае компоновщик установит ссылки на DLL-функции в таблице импортируемых имен скомпонованного EXE-файла и загрузчик Windows автоматически загрузит DLL (во время выполнения главного блока) вместе с файлом EXE:

procedure Foo(X: Integer); external 'BAR' index 1;

Если в течение связывания (также называемое статической линковкой) Windows не сможет найти DLL, вы получите предупреждение - чаще всего File Error MessageBox (как раз то, в котором не указан ненайденный файл - ну очень "полезная" штуковина!). Поэтому вы должны быть абсолютно уверенными в том, что DLL будет доступна все то время, когда вы захотите ей воспользоваться, т.е. всегда.

Динамически связанная DLL, использующая модуль явного импорта, пользуется методами VB, каковые вы также можете использовать, но делая это "вручную". С помощью LoadLibrary по мере необходимости вы загружаете DLL, получаете указатели на экспортируемые функции, которые вы предполагаете использовать с GetProcAddress и освобождаете DLL с помощью FreeLibrary, когда она вам больше не нужна:

var Hbar: Thandle;
Foo: procedure (X: Integer);
begin
Hbar := LoadLibrary('BAR.DLL');
if Hbar >= 32 then { успешно }
begin
Foo := GetProcAddress(HBar, 'FOO');
...
Foo(1);
...
FreeLibrary(HBar);
end
else
MessageDlg('Ошибка: не могу найти BAR.DLL', mtError, [mbOk], 0)
end.

Успехов,
Dr. Bob (drbob@pi.net) [000726]


Delphi 1

Помещение формы в DLL

Вы можете помещать простые формы в DLL на этапе разработки. Это можно сделать с формами, полностью готовыми к работе и не требующими доработки. Вот пример DLL, которая создает, отображает и освобождает форму. В примере была взята экстра-простая форма для того, чтобы показать, что она может быть использована любым языком, не только в Delphi. Как я и обещал, я преподнес вам идею. Гвоздь программы в том, что пока вы проектируете свое приложение, форма из вашей DLL в Delphi *не* загружается. Только не забудьте в конце разработки ее скомпилить :-)) .

Имейте в виду, что все функции в DLL-примере 32-битные. Т.е. после получения с помощью CreateTheForm указателя на форму, необходимые функции получат в свои руки полное 32-битное управление формой. Вероятно вам это и не понадобится, но это пример того, КАК нужно делать...

Library Formdll;

uses
SysUtils,
Forms,
Formdllu in 'FORMDLLU.PAS' {Form1};

FUNCTION CreateTheForm: Pointer; Export;
BEGIN
Result := TForm1.Create(NIL);
END;

PROCEDURE LoadTheForm(P: Pointer; S1, S2, S3: PChar); Export;
BEGIN
WITH TForm1(P) DO
BEGIN
Edit1.Text := StrPas(S1);
Edit2.Text := StrPas(S2);
Edit3.Text := StrPas(S3);
END;
END;

FUNCTION ShowTheForm(P: Pointer): Boolean; Export;
CONST mrOK = 1;
BEGIN
Result := TForm1(P).ShowModal = mrOK;
END;

PROCEDURE ReadTheForm(P:Pointer; S1, S2, S3: PChar); Export;
BEGIN
WITH TForm1(P) DO
BEGIN
StrPCopy(S1, Edit1.Text);
StrPCopy(S2, Edit2.Text);
StrPCopy(S3, Edit3.Text);
END;
END;

PROCEDURE DestroyTheForm(P : Pointer); Export;
BEGIN
TForm1(P).Free;
END;

Exports
CreateTheForm    INDEX 1,
LoadTheForm      INDEX 2,
ReadTheForm      INDEX 3,
ShowTheForm      INDEX 4,
DestroyTheForm   INDEX 5;

begin
end.

- Neil J. Rubenking [000742]


Перехват вызовов функций из динамических библиотек

Den is Com советует:

// проверено и работает для WIN 9x и WinNT
// в юните на первый взгляд, есть структуры , описание которых уже есть в Дельфи , но к сожалению не
// всех и не во всех версиях Дельфи эти структуры присутствуют. Да уж, это не С

Проблема скорее для хакера, а не для программиста. Но существуют ситуации, когда это необходимо. Сложно предположить ситуацию, в которой это может понадобится, но например: можете перехватывать надоевшее окошко о необходимости купить компонент :) . Разумеется этот код предназначен для более широких целей и в более широком варианте позволяет контролировать работу внешней программы, производя "мягкий" взлом - изменения присходят только в памяти и не касаются исполняемого файла на диске. Разумеется можно использовать и для более светлых целей. При использовании данного исходника будьте осторожны: при компилировании пректа с динамическими пакетами перехватываемая функция может находится в пакете, а не в файле программы. Перед перехватом функции необходимо заменить её функцией-ловушкой. Например для MessageBox

type
TMyProc= function (hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT): Integer;stdcall;
PTMyProc=^TMyProc;

function MyMessageBox(hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT): Integer;stdcall;
begin
ShowMessage('Message intercepted');
result:=IDOK ;
end;

и сам перехват происходит так

InterceptDllCall(hInstance,'user32.dll','MessageBoxA', Pointer(@MyMessageBox),PPointer(@myProc),nil);

теперь все вызовы MessageBox будут ссылаться на нашу функцию :) Надеюсь вы помните, что функции MessageBox в user32.dll нет - это только оболочка для MessageBoxА

и обратная операция - восстановление работоспособности старой функции

InterceptDllCall(hInstance,'user32.dll','MessageBoxA',Pointer(myProc),nil,Pointer(@MyMessageBox));

Привожу полностью все файлы проекта:

Intercep.pas

unit intercep;

interface
uses windows,dialogs,SysUtils;
type
PImageDosHeader = ^TImageDosHeader;
{EXTERNALSYM _IMAGE_DOS_HEADER}
_IMAGE_DOS_HEADER = packed record      { DOS .EXE header                  }
e_magic: Word;                     { Magic number                     }
e_cblp: Word;                      { Bytes on last page of file       }
e_cp: Word;                        { Pages in file                    }
e_crlc: Word;                      { Relocations                      }
e_cparhdr: Word;                   { Size of header in paragraphs     }
e_minalloc: Word;                  { Minimum extra paragraphs needed  }
e_maxalloc: Word;                  { Maximum extra paragraphs needed  }
e_ss: Word;                        { Initial (relative) SS value      }
e_sp: Word;                        { Initial SP value                 }
e_csum: Word;                      { Checksum                         }
e_ip: Word;                        { Initial IP value                 }
e_cs: Word;                        { Initial (relative) CS value      }
e_lfarlc: Word;                    { File address of relocation table }
e_ovno: Word;                      { Overlay number                   }
e_res: array [0..3] of Word;       { Reserved words                   }
e_oemid: Word;                     { OEM identifier (for e_oeminfo)   }
e_oeminfo: Word;                   { OEM information; e_oemid specific}
e_res2: array [0..9] of Word;      { Reserved words                   }
e_lfanew: LongInt;                 { File address of new exe header   }
end;
TImageDosHeader = _IMAGE_DOS_HEADER;
//  {$EXTERNALSYM IMAGE_DOS_HEADER}
IMAGE_DOS_HEADER = _IMAGE_DOS_HEADER;

//***************************************
PImageDataDirectory = ^TImageDataDirectory;
_IMAGE_DATA_DIRECTORY = record
VirtualAddress: DWORD;
Size: DWORD;
end;
//  {$EXTERNALSYM _IMAGE_DATA_DIRECTORY}
TImageDataDirectory = _IMAGE_DATA_DIRECTORY;
IMAGE_DATA_DIRECTORY = _IMAGE_DATA_DIRECTORY;
//  {$EXTERNALSYM IMAGE_DATA_DIRECTORY}
//*************
PImageOptionalHeader = ^TImageOptionalHeader;
_IMAGE_OPTIONAL_HEADER = packed record
{ Standard fields. }
Magic: Word;
MajorLinkerVersion: Byte;
MinorLinkerVersion: Byte;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
BaseOfData: DWORD;
{ NT additional fields. }
ImageBase: DWORD;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: Word;
MinorOperatingSystemVersion: Word;
MajorImageVersion: Word;
MinorImageVersion: Word;
MajorSubsystemVersion: Word;
MinorSubsystemVersion: Word;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: Word;
DllCharacteristics: Word;
SizeOfStackReserve: DWORD;
SizeOfStackCommit: DWORD;
SizeOfHeapReserve: DWORD;
SizeOfHeapCommit: DWORD;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: packed array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of TImageDataDirectory;
end;
// {$EXTERNALSYM _IMAGE_OPTIONAL_HEADER}
TImageOptionalHeader = _IMAGE_OPTIONAL_HEADER;
IMAGE_OPTIONAL_HEADER = _IMAGE_OPTIONAL_HEADER;
// {$EXTERNALSYM IMAGE_OPTIONAL_HEADER}

PImageNtHeaders = ^TImageNtHeaders;
_IMAGE_NT_HEADERS = packed record
Signature: DWORD;
FileHeader: TImageFileHeader;
OptionalHeader: TImageOptionalHeader;
end;
// {$EXTERNALSYM _IMAGE_NT_HEADERS}
TImageNtHeaders = _IMAGE_NT_HEADERS;
IMAGE_NT_HEADERS = _IMAGE_NT_HEADERS;
// {$EXTERNALSYM IMAGE_NT_HEADERS}

PImage_import_by_name = ^TImage_import_by_mame;
_IMAGE_IMPORT_BY_NAME=packed record
Hint:Word;
Name:Byte;
end;
TImage_import_by_mame =_IMAGE_IMPORT_BY_NAME;

_u1=packed record
case Integer of
0: (ForwarderString:PByte);
1: (Functionn:PDWORD);
2: (Ordinal: DWORD);
3: (AddressOfData:PImage_import_by_name);
end;
PImageThunkData=^TImageThunkData;
_IMAGE_THUNK_DATA=packed record
u1:_u1;
end;
TImageThunkData=_IMAGE_THUNK_DATA;
IMAGE_THUNK_DATA=_IMAGE_THUNK_DATA;
_temp_charcteristics=record
case Integer of
0:(Characteristics:DWORD); // 0 for terminating null import descriptor
1:(OriginalFirstThunk:PImageThunkData);// RVA to original unbound IAT
end;

PImageImportDescriptor=^TImageImportDescriptor;
_IMAGE_IMPORT_DESCRIPTOR = packed record
t:_temp_charcteristics;
TimeDateStamp:DWord;                  // 0 if not bound,
// -1 if bound, and real date\time stamp
//     in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)
// O.W. date/time stamp of DLL bound to (Old BIND)
ForwarderChain:DWORD;                 // -1 if no forwarders
Name:DWORD;
FirstThunk:PImageThunkData;           // RVA to IAT (if bound this IAT has actual addresses)
end; TImageImportDescriptor=_IMAGE_IMPORT_DESCRIPTOR;
IMAGE_IMPORT_DESCRIPTOR=_IMAGE_IMPORT_DESCRIPTOR;
PPointer=^Pointer;
function InterceptDllCall(
hLocalModule:HModule;
c_szDllName:Pchar;
c_szApiName:PChar;
pApiNew:Pointer;
p_pApiOrg:PPointer;
pApiToChange:Pointer):Boolean;
implementation
function MakePtr(base:Dword;Offset:DWORD):Pointer;
begin
Result:=Pointer(Base+Offset);
end;
function InterceptDllCall(
hLocalModule:HModule;
c_szDllName:Pchar;
c_szApiName:PChar;
pApiNew:Pointer;
p_pApiOrg:PPointer;
pApiToChange:Pointer):Boolean;

var pDosHeader:PImageDosHeader;
pNtHeader:PImageNtHeaders;
PImportDesc:PImageImportDescriptor;
dwProtect:DWORD;
dwNewProtect:DWORD;
dwAddressToInterCept:DWORD;
pThunk:PImageThunkData;
begin
pDosHeader:=PImageDosHeader(hLocalModule);
Result:=False;
if (pApiToChange<>nil) then
dwAddressToIntercept:=DWORD(pApiToChange)
else
dwAddressToIntercept:=Dword(GetProcAddress(GetModuleHandle(c_szDllName),c_szApiName));

if IsBadReadPtr(Pointer(hLocalModule),sizeof(PImageNtHeaders)) then Exit;

if pDosHeader.e_magic<>IMAGE_DOS_SIGNATURE then exit;
pNtHeader:=PImageNtHeaders(MakePtr(DWord(pDOSHeader),DWord(pDOSHeader.e_lfanew)));
if pNTHeader.signature<>IMAGE_NT_SIGNATURE then exit;
pImportDesc:=PImageImportDescriptor(
MakePtr(hLocalModule,
pNtHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress));

if (PImportDesc=PImageImportDescriptor(pNtHeader))  then exit;

while(pImportDesc.Name>0)do
begin
pThunk:=PImageThunkData(MakePtr(DWord(hLocalModule),
Dword(pImportDesc.FirstThunk)));
while(pThunk.u1.Functionn<>nil) do
begin
if DWord(pThunk.u1.Functionn)=dwAddressToIntercept then
begin
if not IsBadWritePtr(Pointer(@pThunk.u1.Functionn),sizeof(DWORD)) then
begin
if (p_pApiOrg<>nil) then
p_pApiOrg^:=Pointer(pThunk.u1.Functionn);
pThunk.u1.Functionn:=pApiNew;
Result:=True;
end
else
begin
if VirtualProtect(Pointer(@pThunk.u1.Functionn),sizeof(DWORD),PAGE_EXECUTE_READWRITE,@dwProtect) then
begin
if (p_pApiOrg<>nil) then p_pApiOrg^:=Pointer(pThunk.u1.Functionn);
pThunk.u1.Functionn:=PDWORD(pApiNew);
Result:=True;
dwNewProtect:=dwProtect;
VirtualProtect(Pointer(@pThunk.u1.Functionn),sizeof(DWORD),dwNewProtect,@dwProtect);
end;
end;
end;
Inc(PThunk);
end;
Inc(pImportDEsc);
end;
end;

end.

Project1.dpr

program Project1;

uses
Forms,
Unit1 in '..\..\Work\Temp\4\Unit1.pas' {Form1};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Unit1.dfm

object Form1: TForm1
Left = 192
Top = 107
Width = 435
Height = 300
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 Button1: TButton
Left = 72
Top = 176
Width = 273
Height = 65
Caption = 'Begin'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -24
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 304
Top = 16
Width = 105
Height = 49
Caption = 'MessageBox'
TabOrder = 1
OnClick = Button2Click
end
end

Unit1.pas

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,intercep;

type

TMyProc= function (hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT): Integer;stdcall;
PTMyProc=^TMyProc;

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;
myProc:PTMyProc;
implementation
function MyMessageBox(hWnd: HWND; lpText, lpCaption: PAnsiChar; uType: UINT): Integer;stdcall;
begin
ShowMessage('Message intercepted');

result:=IDOK ;
end;
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin
myProc:=nil;
MessageBox(0,'Hello','Message 1',MB_OK);
InterceptDllCall(hInstance,'user32.dll','MessageBoxA',
Pointer(@MyMessageBox),PPointer(@myProc),nil);//then ShowMessage('Ok');
MessageBox(0,'Hello','Message 2',MB_OK);
InterceptDllCall(hInstance,'user32.dll','MessageBoxA',
Pointer(myProc),nil,Pointer(@MyMessageBox));
MessageBox(0,'Hello','Message 3 ',MB_OK);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
MessageBox(0,'Hello','Message 4 ',MB_OK);
end;

end.

[000807]


Delphi 1

Закрытие файла, открытого в DLL

Как мне закрыть файл, открытый в DLL (созданный в Delphi), и вызванный из VB?

Это известная проблема. Это происходит от того, что VB закрывает при запуске 5 стандартных DOS-дескрипторов (0..4). Так, программа, открывшая файл, повторно использует один из этих дескрипторов, чтобы первой открыть файл с локального файла. Проблемы при использовании файла не возникает, но паскалевская процедура Close использует характеристику "безопасной" работы: она отказывается закрывать файл, если он имеет один из стандартных дексрипторов! Такая функциональность хороша под DOS, но в нашей ситуации файл, открытый DLL никогда не закроется, даже если DLL завершит свою работу! VC++, очевидно, менее закомплексован в данном вопросе, и поэтому закрывает стандартный дескриптор.

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

Procedure ReallyCloseFileVar(Var F); Assembler;
{ F должен иметь тип File }
Asm
les  bx, F                { сохраняем F в es:bx }
mov  bx, word ptr es:[bx] { сохраняем дескриптор в bx }
mov  ah, $3E              { функция 3Eh аналогична закрытию файла }
call Dos3Call             { задействуем прерывание int 21h }
End;

Procedure ReallyCloseFileHandle(FileHandle: word); assembler;
{ FileHandle - дескриптор DOS-файла }
asm
mov  bx, Handle { сохраняем дескриптор в bx }
mov  ah, $3E    { функция 3Eh аналогична закрытию файла }
call DOS3Call   { задействуем прерывание int 21h }
end;

[000837]


Delphi 2

Соглашения о вызовах DLL I

Кто-нибудь может мне сказать, почему мои перекомпилированные DLL-ки не грузятся? Передаются только данные, имеющие тип pchars и integer.

Одно отличие между 16- и 32-битной версией Delphi - соглашение о вызове. 16-битная версия использует по умолчанию вызов PASCAL (перекрываемый CDECL). 32-битная использует по умолчанию FASTCALL, но может перекрываться CDECL, PASCAL или STDCALL.

Я не уверен в том, что сейчас использует VB (в 16-битном Windows API был Pascal, в 32-битном - STDCALL). Я добавляю ко всем экспортируемым функциям ключевое слово "PASCAL". Если это не решает проблему, попробуйте использовать "STDCALL".

- David Berg [000878]


Соглашения о вызовах DLL II

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

PASCAL - Порядок вызова слева направо, за выгрузку стека отвечает вызываемая подпрограмма.

STDCALL - Порядок вызова справа налево, за выгрузку стека отвечает вызываемая подпрограмма.

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

STDCALL был добавлен Microsoft для Win32. В нем скомбинированы лучшие черты Pascal (очистка стека вызываемой подпрограммой) и CDECL (аргументы выталкиваются слева направа - первый аргумент находится на вершине стека - делает простым использование счетчика переменного количества аргументов). Перед STDCALL Windows всегда использовался PASCAL, а для вызовов всех переменных аргументов использовался CDECL. Теперь для всего этого всегда используется STDCALL.

FASTCALL реально доступен в 16-битных BC, но его используют не так много программистов. Тем не менее, для вызова небольших быстрых подпрограмм, не организующих выталкивание и помещение аргументов и не строящих кадры стека, кадры могут быть расширены. Для примера, подпрограмма MIN/MAX выполняющая около 15 инструкций, выполняет 5, плюс дополнительные инструкции, по большей части для работы с регистрами, где старые инструкции работали с памятью. Это не дало бы такого эффекта в C поскольку: (a) такие простые программы реализовываются на уровне макросов, и/или (b) компилятор имел тенденцию работать во всяком случае с inline.

- Dave Berg [000922]


Delphi 2

Потоки и DLL

Потоки и DLL-ки

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

Техническая сторона вопроса будет сфокусирована на потоках и функции DllEntryPoint. Функция DllEntryPoint не должна объявляться в ваших Delphi DLL. Фактически, большую часть, если не всю, Delphi DLL будет правильно работать и без вашего явного объявления DllEntryPoint. Тем не менее, я включил данный совет для тех Win32-программистов, которые понимают эту функцию и хотят связать с ней свое функциональное назначение, чтобы оно являлось частью DLL. Чтобы быть более конкрентым, это будет интересно тем программистам, которые хотят вызывать одну и ту же DLL из многочисленных потоков одной программы.

Исходный код данного проекта находится на FTP компании Borland и доступен по адресу:

ftp.borland.com/pub/techinfo/techdocs/language/delphi/gen/bi42.zip

Данный код также доступен на 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.

- Charles Calvert [000886]


Одной строкой

Синтаксис вызова DLL

Существует различие в использовании "external" для различных версий Delphi и операционных систем.

16-битное приложение *НЕ* должно содержать "external".

32-битное приложение *ДОЛЖНО* содержать "external" для NT и дополнительно для Win95. [000914]


Delphi 2

Простой пример DLL

Вот ДЕЙСТВИТЕЛЬНО простейшая Delphi 2.0 DLL:

library MyDll;

uses
Windows;

function SomeFunc(I: Integer): Integer; stdcall;
begin
if Odd(I) then Result := 3 * I + 1
else Result := I div 2;
end;

exports
SomeFunc;

begin
end.

И вот модуль импорта, который вы можете включить в любой проект, которому необходим доступ к функциям DLL:

unit MyDllImport;

interface

uses
Windows;

function SomeFunc(I: Integer): Integer; stdcall;

implementation

function SomeFunc; external 'mydll.dll';

end.

-Steve Schafer [000948]


Delphi / MS Office 97 / OLE / VB для приложений

Здесь мы ответим на действительно интересные вопросы:
  • Как узнать, установлен ли Word 8 на машине клиента?
  • Где расположены шаблоны?
  • Почему запускается все время новый документ, когда я хочу работать в том же?
  • Как найти документ, с которым пользователь работал в последнее время?
  • Почему Word закрывается после завершения моей процедуры?
  • Как мне добраться до папок программы Outlook?
  • Как в Outlook получить доступ к существующему контакту или создать свой?

    • {--------------------Взято из библиотеки типов--------------- WORDDEC.INC}
    Const
    // OlAttachmentType
    olByValue = 1;
    olByReference = 4;
    olEmbeddedItem = 5;
    olOLE = 6;
    // OlDefaultFolders
    olFolderDeletedItems = 3;
    olFolderOutbox = 4;
    olFolderSentMail = 5;
    olFolderInbox = 6;
    olFolderCalendar = 9;
    olFolderContacts = 10;
    olFolderJournal = 11;
    olFolderNotes = 12;
    olFolderTasks = 13;
    // OlFolderDisplayMode
    olFolderDisplayNormal = 0;
    olFolderDisplayFolderOnly = 1;
    olFolderDisplayNoNavigation = 2;
    // OlInspectorClose
    olSave = 0;
    olDiscard = 1;
    olPromptForSave = 2;
    // OlImportance
    olImportanceLow = 0;
    olImportanceNormal = 1;
    olImportanceHigh = 2;
    // OlItems
    olMailItem = 0;
    olAppointmentItem = 1;
    olContactItem = 2;
    olTaskItem = 3;
    olJournalItem = 4;
    olNoteItem = 5;
    olPostItem = 6;
    // OlSensitivity
    olNormal = 0;
    olPersonal = 1;
    olPrivate = 2;
    olConfidential = 3;
    // OlJournalRecipientType;
    olAssociatedContact = 1;
    // OlMailRecipientType;
    olOriginator = 0;
    olTo = 1;
    olCC = 2;
    olBCC = 3;

    Const
    wdGoToBookmark = -1;
    wdGoToSection = 0;
    wdGoToPage = 1;
    wdGoToTable = 2;
    wdGoToLine = 3;
    wdGoToFootnote = 4;
    wdGoToEndnote = 5;
    wdGoToComment = 6;
    wdGoToField = 7;
    wdGoToGraphic = 8;
    wdGoToObject = 9;
    wdGoToEquation = 10;
    wdGoToHeading = 11;
    wdGoToPercent = 12;
    wdGoToSpellingError = 13;
    wdGoToGrammaticalError = 14;
    wdGoToProofreadingError = 15;

    wdGoToFirst = 1;
    wdGoToLast = -1;
    wdGoToNext = 2;   //интересно,
    wdGoToRelative = 2;  //чем отличаются эти две константы?
    wdGoToPrevious = 3;
    wdGoToAbsolute = 1;

    Основные функции:

    Function GetWordUp(StartType : string):Boolean;
    Function InsertPicture(AFileName : String) : Boolean;
    Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean;
    Function GetOutlookUp(ItemType : Integer): Boolean;
    Function MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean;
    Function ImportOutlookContact : Boolean;
    Function GetOutlookFolderItemCount : Integer;
    Function GetThisOutlookItem(AnIndex : Integer) : Variant;
    Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean;
    Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
    Function CloseOutlook : Boolean;

    Type TTreeData = class(TObject)
    Public
    ItemId : String;
    end;

    {$I worddec.inc} {все константы из библиотеки типов тащим с собой}

    Var
    myRegistry : TRegistry;
    GotWord : Boolean;
    WhereIsWord : String;
    WordDoneMessage : Integer;
    Basically : variant;
    Wordy: Variant;
    MyDocument : Variant;
    MyOutlook : Variant;
    MyNameSpace : Variant;
    MyFolder : Variant;
    MyAppointment : Variant;

    Function GetWordUp(StartType : string):Boolean;
    // Запускаем Word "правильным" на мой взгляд способом
    // после старта Word мы сделаем так, чтобы после завершения приложения он остался открытым
    var   i : integer;
    AHwnd : Hwnd;
    AnAnswer : Integer;
    temp : string;
    MyDocumentsCol : Variant;
    TemplatesDir : Variant;
    OpenDialog1 : TopenDialog;

    begin
    result := false;
    myRegistry := Tregistry.Create;
    myRegistry.RootKey := HKEY_LOCAL_MACHINE;
    // никакого "word 8", никакой функции!
    If myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word')
    then
    GotWord := true
    Else
    GotWord := false;
    If GotWord then
    //где он, черт побери?
    If myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then
    begin
    WhereisWord := myRegistry.ReadString('BinDirPath');
    MyRegistry.CloseKey;
    end
    else
    GotWord := false;
    If GotWord then
    //и где эти надоевшие шаблоны?
    Begin
    MyRegistry.RootKey := HKEY_CURRENT_USER;
    If
    myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates', false) then
    Begin
    TemplatesDir := myRegistry.ReadString(Nothing);
    MyRegistry.CloseKey;
    end
    Else
    Begin
    Warning('Ole инсталляция','Шаблоны рабочей группы не установлены');
    GotWord := false;
    end;
    End;
    myRegistry.free;
    If not gotword then
    Begin
    Warning('Ole дескриптор', 'Word не установлен');
    exit;
    end;
    //это имя класса принадлежит главному окну в двух последних версиях Word
    temp := 'OpusApp';
    AHwnd :=  FindWindow(pchar(temp),nil);
    If (AHwnd = 0) then
    //Word не запущен, пробуем запустить пустую оболочку без документа
    Begin
    Temp := WhereisWord + '\winword.exe /n';
    AnAnswer := WinExec(pchar(temp), 1);
    If (AnAnswer < 32) then
    Begin
    Warning('Ole дескриптор', 'Не могу найти WinWord.exe');
    Exit;
    End;
    End;

    Application.ProcessMessages;
    {Если вы уже используете Word.Application, вы получаете ваш собственный экземпляр}
    {Если вы уже используете Word.Document, вы получаете работающий экземпляр}
    {по-моему все понятно и очень удобно (во всяком случае мне)}
    try {создаем новый документ}
    Basically := CreateOleObject('Word.Document.8');
    except
    Warning('Ole дескриптор', 'Не могу запустить Microsoft Word.');
    Result := False;
    Exit;
    end;
    Try {ссылаемся в переменной вариантного на вновь созданный документ}
    Wordy := Basically.Application;
    Except
    Begin
    Warning('Ole дескриптор', 'Не могу получить доступ к Microsoft Word.');
    Wordy := UnAssigned;
    Basically := UnAssigned;
    Exit;
    end;
    end;

    Application.ProcessMessages;

    Wordy.visible := false;
    MyDocumentsCol := Wordy.Documents;
    {Проверяем количество открытых документов и пытаемся вывести диалог выбора шаблона}
    If (MyDocumentsCol.Count = 1) or
    (StartType = 'New') then
    Begin
    OpenDialog1 := TOpenDialog.Create(Application);
    OpenDialog1.filter := 'Шаблоны Word|*.dot|Документы Word|*.doc';
    OpenDialog1.DefaultExt := '*.dot';
    OpenDialog1.Title := 'Выберите ваш шаблон';
    OpenDialog1.InitialDir := TemplatesDir;
    If OpenDialog1.execute then
    Begin
    Wordy.ScreenUpdating:= false;
    MyDocumentsCol := wordy.Documents;
    MyDocumentsCol.Add(OpenDialog1.Filename, False);
    OpenDialog1.free;
    end
    Else
    begin
    OpenDialog1.Free;
    Wordy.visible := true;
    Wordy := Unassigned;
    Basically := Unassigned;
    Exit;
    end;
    end
    Else
    {закрываем документ}
    MyDocument.close(wdDoNotSaveChanges);

    {теперь мы имеем или новый документ на основе шаблона, выбранного пользователем
    или же его текущий документ}
    MyDocument := Wordy.ActiveDocument;
    Result := true;
    Application.ProcessMessages;

    end;

    Function InsertPicture(AFileName : String) : Boolean;
    var
    MyShapes : Variant;
    MyRange : variant;

    begin
    Result := True;
    If GetWordUp('Current')then
    Try
    Begin
    MyRange := MyDocument.Goto(wdgotoline, wdgotolast);
    MyRange.EndOf(wdParagraph, wdMove);
    MyRange.InsertBreak(wdPageBreak);
    MyShapes := MyDocument.InlineShapes;
    MyShapes.AddPicture(afilename, false, true, MyRange);
    end;
    Finally
    begin
    Wordy.ScreenUpdating:= true;
    Wordy.visible := true;
    Wordy := Unassigned;
    Basically := UnAssigned;
    Application.ProcessMessages;
    end;
    end
    else
    Result := False;

    end;

    Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId) : Boolean;
    var
    MyCustomProps : Variant;
    begin
    { лично я сначала сохраняю свою визитку в свойствах документа, а только
    потом вывожу панели с инструментами для того, чтобы пользователь мог
    "установить" принадлежность шаблона или текущего документа.

    на мой взгляд здесь есть три достоинства (здесь нет подвохов, уверяю вас):
    1. Пользователь может установить свои свойства документа после того,
    как функция отработает
    2. Другие свойства могут быть установлены в любом месте
    того же документа
    3. Пользователь может переслать эти свойства в тот же Outlook или с их
    помощью найти документ, используя функции расширенного поиска Word}

    Result := true;
    If GetWordUp('New')then
    Try
    Begin
    MyCustomProps := MyDocument.CustomDocumentProperties;
    MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id);
    MyCustomProps.add(cpOrganizationName,
    false, msoPropertyTypeString, MyId.OrganizationName);
    MyCustomProps.add(cpAddress1,
    false, msoPropertyTypeString,MyId.Address1);
    MyCustomProps.add(cpAddress2, false,
    msoPropertyTypeString, MyId.Address2);
    MyCustomProps.add(cpCity, false,
    msoPropertyTypeString, MyId.City);
    MyCustomProps.add(cpStProv, false,
    msoPropertyTypeString, MyId.StProv);
    MyCustomProps.add(cpCountry,
    false, msoPropertyTypeString,MyId.City);
    MyCustomProps.add(cpPostal, false,
    msoPropertyTypeString, MyId.Country);
    MyCustomProps.add(cpAccountId, false,
    msoPropertyTypeString, MyId.AccountId);
    MyCustomProps.add(cpFullName, false,
    msoPropertyTypeString, MyContId.FullName);
    MyCustomProps.add(cpSalutation, false,
    msoPropertyTypeString, MyContId.Salutation);
    MyCustomProps.add(cpTitle, false,
    msoPropertyTypeString,MyContId.Title);
    If (MyContId.workPhone = Nothing) or
    (MycontId.WorkPhone = ASpace) then
    MyCustomProps.add(cpPhone, false,
    msoPropertyTypeString, MyId.Phone )
    else
    MyCustomProps.add(cpPhone, false,
    msoPropertyTypeString, MyContId.WorkPhone );
    If (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then
    MyCustomProps.add(cpFax, false,
    msoPropertyTypeString, MyId.Fax)
    else
    MyCustomProps.add(cpFax, false,
    msoPropertyTypeString,MyContId.Fax);
    If (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then
    MyCustomProps.add(cpEmail, false,
    msoPropertyTypeString, MyId.Email)
    else
    MyCustomProps.add(cpEmail, false,
    msoPropertyTypeString, MyContId.Email);
    MyCustomProps.add(cpFirstName, false,
    msoPropertyTypeString,MyContId.FirstName);
    MyCustomProps.add( cpLastName, false,
    msoPropertyTypeString, MyContId.LastName);
    MyDocument.Fields.Update;
    end;
    Finally
    begin
    Wordy.ScreenUpdating:= true;
    Wordy.visible := true;
    Wordy := Unassigned;
    Basically := UnAssigned;
    Application.ProcessMessages;
    end;
    end
    Else
    Result := false;
    end;

    Function GetOutlookUp(ItemType : Integer): Boolean;
    Const
    AppointmentItem = 'Calendar';
    TaskItem = 'Tasks';
    ContactItem = 'Contacts';
    JournalItem = 'Journal';
    NoteItem = 'Notes';
    var
    MyFolders : Variant;
    MyFolders2 : variant;
    MyFolders3 : variant;
    MyFolder2 : Variant;
    MyFolder3 : variant;
    MyUser : Variant;
    MyFolderItems : Variant;
    MyFolderItems2 : Variant;
    MyFolderItems3 : Variant;
    MyContact : Variant;
    i, i2, i3 : Integer;
    MyTree : TCreateCont;
    MyTreeData : TTreeData;
    RootNode, MyNode, MyNode2 : ttreeNode;
    ThisName : String;

    Begin
    {это действительно безобразие........
    В Outlook несколько странно реализована объектная модель,
    и такие перлы как folder.folder.folder считаются "верным решением"
    для получения доступа к папкам этой великолепной программы.}

    {пользователь выбирает папку из дерева папок}
    Result := False;
    Case ItemType of
    olAppointmentItem : ThisName := AppointmentItem;
    olContactItem : ThisName := ContactItem;
    olTaskItem : ThisName := TaskItem;
    olJournalItem : ThisName := JournalItem;
    olNoteItem : ThisName := NoteItem;
    Else
    ThisName := 'Unknown';
    End;

    try
    MyOutlook := CreateOleObject('Outlook.Application');
    except
    warning('Ole интерфейс','Не могу запустить Outlook.');
    Exit;
    end;
    {это папка верхнего уровня}
    MyNameSpace := MyOutlook.GetNamespace('MAPI');
    MyFolderItems := MyNameSpace.Folders;
    MyTree := TCreateCont.create(Application);
    {Действительно неудачно, ведь пользователь может создать что-то другое,
    чем папки, предлагаемые по-умолчанию, на которые мы и хотели опереться
    в нашей программе, поэтому перемещаемся на нижний уровень в цепочке папок}
    MyTree.Caption := 'Выбрана ' + ThisName + ' папка';
    With MyTree do
    If MyFolderItems.Count > 0 then
    For i := 1 to MyFolderItems.Count do begin
    MyFolder := MyNameSpace.Folders(i);
    MyTreeData := TTreeData.create;
    MyTreeData.ItemId := MyFolder.EntryId;
    RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData);
    MyFolders2 := MyNameSpace.folders(i).Folders;
    If MyFolders2.Count > 0 then
    for i2 := 1 to MyFolders2.Count do begin
    MyFolder2 := MyNameSpace.folders(i).Folders(i2);
    If (MyFolder2.DefaultItemType = ItemType)
    or (MyFolder2.Name = ThisName) then
    Begin
    MyTreeData := TTreeData.create;
    MyTreeData.ItemId := MyFolder2.EntryId;
    {вот мы и добрались непосредственно до папок}
    MyNode :=
    Treeview1.Items.addChildObject(RootNode, MyFolder2.Name, MyTreeData);
    MyFolders3 :=
    MyNameSpace.folders(i).Folders(i2).Folders;
    If MyFolders3.Count > 0 then
    for i3 := 1 to MyFolders3.Count do
    begin
    MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3);
    If (MyFolder3.DefaultItemType = ItemType) then
    Begin
    MyTreeData := TTreeData.create;
    MyTreeData.ItemId := MyFolder3.EntryId;
    MyNode2 :=
    Treeview1.Items.addChildObject(MyNode, MyFolder3.Name, MyTreeData);
    end;
    end;
    end;
    end;
    end;
    If MyTree.TreeView1.Items.Count = 2 then
    {есть только корневая папка и папка, определенная мной}
    MyFolder :=
    MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId
    )
    Else
    begin
    MyTree.Treeview1.FullExpand;
    MyTree.ShowModal;
    If MyTree.ModalResult = mrOk then
    Begin
    If MyTree.Treeview1.Selected <> nil then
    MyFolder :=
    MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId
    );
    end
    else
    Begin
    MyOutlook := UnAssigned;
    For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
    TTreeData(MyTree.Treeview1.Items[i].Data).free;
    MyTree.release;
    exit;
    end;
    end;
    For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
    TTreeData(MyTree.Treeview1.Items[i].Data).free;
    MyTree.release;
    Result := true;
    end;

    Function MakeOutlookContact(MyId : TMyId; MyContId : TMyContId) : boolean;
    var      MyContact : Variant;
    begin
    Result := false;
    If not GetOutlookUp(OlContactItem)
    then exit;
    MyContact := MyFolder.Items.Add(olContactItem);
    MyContact.Title := MyContId.Honorific;
    MyContact.FirstName := MyContId.FirstName;
    MyContact.MiddleName := MycontId.MiddleInit;
    MyContact.LastName := MycontId.LastName;
    MyContact.Suffix := MyContId.Suffix;
    MyContact.CompanyName := MyId.OrganizationName;
    MyContact.JobTitle := MyContId.Title;
    MyContact.OfficeLocation := MyContId.OfficeLocation;
    MyContact.CustomerId := MyId.ID;
    MyContact.Account := MyId.AccountId;
    MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2;
    MyContact.BusinessAddressCity := MyId.City;
    MyContact.BusinessAddressState := MyId.StProv;
    MyContact.BusinessAddressPostalCode := MyId.Postal;
    MyContact.BusinessAddressCountry := MyId.Country;
    If (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then
    MyContact.BusinessFaxNumber := MyId.Fax
    Else
    MyContact.BusinessFaxNumber := MyContId.Fax;
    If (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace)
    then
    MyContact.BusinessTelephoneNumber := MyId.Phone
    Else
    MyContact.BusinessTelephoneNumber := MyContId.WorkPhone;
    MyContact.CompanyMainTelephoneNumber := MyId.Phone;
    MyContact.HomeFaxNumber := MyContId.HomeFax;
    MyContact.HomeTelephoneNumber := MyContId.HomePhone;
    MyContact.MobileTelephoneNumber := MyContId.MobilePhone;
    MyContact.OtherTelephoneNumber := MyContId.OtherPhone;
    MyContact.PagerNumber := MyContId.Pager;
    MyContact.Email1Address := MyContId.Email;
    MyContact.Email2Address := MyId.Email;
    Result := true;
    Try MyContact.Save;
    Except
    Result := false;
    end;
    MyOutlook := Unassigned;

    end;

    Function GetThisOutlookItem(AnIndex : Integer) : Variant;
    Begin
    Result := myFolder.Items(AnIndex);
    end;

    Function GetOutlookFolderItemCount : Integer;
    Var myItems : Variant;
    Begin
    Try MyItems := MyFolder.Items;
    Except
    Begin
    Result := 0;
    exit;
    end;
    end;
    Result := MyItems.Count;
    end;

    Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :
    Boolean;
    Begin
    {не забудьте предварительно инициализировать AItem значением NIL}
    Result := true;
    Try
    AItem := myFolder.Items.Find(AFilter);
    Except
    Begin
    aItem := MyFolder;
    Result := false;
    end;
    End;

    End;

    Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
    Begin
    Result := true;
    Try
    AItem := myFolder.Items.FindNext;
    Except
    Begin
    AItem := myFolder;
    Result := false;
    end;
    End;
    End;

    Function CloseOutlook : Boolean;
    begin
    Try MyOutlook := Unassigned;
    Except
    End;
    Result := true;

    end;

    Как использовать весь этот код?
    Вот модуль для работы с Контактами программы Outlook.
    Строим расширенный список контактов (компонент TExtListView вы можете найти на www.torry.ru).

    unit UImpContact;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    UMain, StdCtrls, Buttons, ComCtrls, ExtListView;

    type
    TFindContact = class(TForm)
    ContView1: TExtListView;
    SearchBtn: TBitBtn;
    CancelBtn: TBitBtn;
    procedure SearchBtnClick(Sender: TObject);
    procedure CancelBtnClick(Sender: TObject);
    procedure ContView1DblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

    var
    FindContact: TFindContact;

    implementation
    Uses     USearch;

    {$R *.DFM}

    procedure TFindContact.SearchBtnClick(Sender: TObject);
    begin
    If ContView1.Selected <> nil then
    ContView1DblClick(nil);
    end;

    procedure TFindContact.CancelBtnClick(Sender: TObject);
    begin
    CloseOutlook;
    ModalResult := mrCancel;
    end;

    procedure TFindContact.ContView1DblClick(Sender: TObject);
    var MyContact : variant;
    begin
    If ContView1.Selected <> nil then Begin
    MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2]));
    With StartForm.MyId do
    If Not GetData(MyContact.CustomerId) then begin
    InitData;
    If MyContact.CustomerId <> '' then
    Id := MyContact.CustomerId
    Else
    Id := MyContact.CompanyName;
    If DoesIdExist(Startform.MyId.Id) then begin
    Warning('Дескриптор данных', 'Не могу установить уникальный Id' + CRLF
    + 'Отредактируйте CustomerId в Outlook и попытайтесь снова');
    CloseOutlook;
    ModalResult := mrCancel;
    Exit;
    end;
    OrganizationName := MyContact.CompanyName;
    IdType := 1;
    AccountId := MyContact.Account;
    Address1 := MyContact.BusinessAddressStreet;
    City := MyContact.BusinessAddressCity;
    StProv := MyContact.BusinessAddressState ;
    Postal := MyContact.BusinessAddressPostalCode;
    Country := MyContact.BusinessAddressCountry;
    Phone := MyContact.CompanyMainTelephoneNumber;
    Insert;
    end;
    With StartForm.MyContId do begin
    InitData;
    ContIdId := StartForm.MyId.Id;
    Honorific := MyContact.Title ;
    FirstName := MyContact.FirstName ;
    MiddleInit := MyContact.MiddleName ;
    LastName := MyContact.LastName ;
    Suffix := MyContact.Suffix ;
    Fax :=    MyContact.BusinessFaxNumber ;
    WorkPhone :=   MyContact.BusinessTelephoneNumber;
    HomeFax := MyContact.HomeFaxNumber ;
    HomePhone := MyContact.HomeTelephoneNumber ;
    MobilePhone := MyContact.MobileTelephoneNumber ;
    OtherPhone := MyContact.OtherTelephoneNumber ;
    Pager := MyContact.PagerNumber ;
    Email := MyContact.Email1Address ;
    Title := MyContact.JobTitle;
    OfficeLocation := MyContact.OfficeLocation ;
    Insert;
    End;
    end;
    CloseOutlook;
    ModalResult := mrOk;

    end;

    procedure TFindContact.FormCreate(Sender: TObject);
    var      MyContact : Variant;
    MyCount : Integer;
    i : Integer;
    AnItem : TListItem;
    begin
    If not GetOutlookUp(OlContactItem)
    then exit;
    MyCount := GetOutlookFolderItemCount ;
    For i := 1 to MyCount do begin
    MyContact := GetThisOutlookItem(i);
    AnItem := ContView1.Items.Add;
    AnItem.Caption := MyContact.CompanyName;
    AnItem.SubItems.add(MyContact.FirstName);
    AnItem.Subitems.Add(MyContact.LastName);
    AnItem.SubItems.Add(inttostr(i));
    End;

    end;

    procedure TFindContact.FormClose(Sender: TObject;
    var Action: TCloseAction);
    begin
    Action := cafree;
    end;

    end.

    [000187]


Получение данных из Delphi-приложения в документе Word

Допустим что у вас имеется Word2(6)/Delphi1 или 32bit Word/Delphi2.

Сделайте следующее:

  • Создайте макрос в Word:

    Declare Function StringFromDelphi Lib "c:\sample\test.dll" As String

    Sub MAIN
    mystring$ = StringFromDelphi
    Insert mystring$
    End Sub

  • Создайте простой TEST.DLL в Delphi - просто форма с кнопкой. Сохраните это (например в c:\sample - смотри макрос Word) как test.dpr и testform.pas. Теперь добавьте к вашему проекту экспортируемую функцию 'StringFromDelphi' и 'close' на нажатие кнопки. Вы можете использовать следующий код:

    library Test;  (* test.dpr в c:\sample *)
    uses Testform in 'TESTFORM.PAS';
    exports
    StringFromDelphi;
    begin
    end    .

    unit Testform; (* testform.pas в c:\sample *)
    interface
    uses
    WinTypes, WinProcs, Forms, Classes, Controls, StdCtrls, SysUtils;

    type
    TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    end;
    var
    Form1: TForm1;

    function StringFromDelphi : PChar; export;
    {$ifdef WIN32} stdcall; {$endif}

    implementation
    {$R *.DFM}

    function StringFromDelphi: Pchar;
    var StringForWord : array[0..255] of char;
    begin
    Application.CreateForm(TForm1, Form1);
    Form1.ShowModal;
    Result:=StrPCopy(StringForWord, Form1.Button1.caption);
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    close;
    end;

    end.

  • Скомпилируйте test.dll. Запустите макрос из Word - должна появиться форма Delphi - нажмите кнопку для получения некоторых данных из Delphi.

    В журнале PCMagazine Vol12.No22 опубликована статья о доступе к DLL из Word. Ознакомиться с ней вы можете в электронной версии журнала на веб-сайте PCMagazine.

    [000190]


WordBasic через OLE

Попробуйте следующее:

MsWord := CreateOleObject('Word.Basic');
MsWord.FileNewDefault;
MsWord.TogglePortrait;

[000191]


Создание документов Word

Я обнаружил, что следующий код работает хорошо в связке Delphi -> Word 97 (с использованием поля "Закладки" в Word):

..
..
..

implementation

uses OleAuto;
..
..
..
var
V : Variant ;

..
..
..
V := 0; // не забудьте инициализировать переменную

..
..
.. другие функции

if V = 0 then
begin
V := CreateOLEObject('Word.Application');
V.WordBasic.AppShow;
end;

// данный пример показывает технологию заполнения полей
// некой закладки в "стандартном письме" с помощью запроса,
// выполненного прежде в модуле данных pnm_data (OK,
// надо было бы использовать блок with...!)
V.WordBasic.Fileopen('Имя вашего документа Word');
V.WordBasic.EditBookmark('Заголовок',0,0,0,1);
V.WordBasic.Insert(Title);
V.WordBasic.EditBookmark('Имя',0,0,0,1);
V.WordBasic.Insert(FirstName + ' ');
V.WordBasic.EditBookmark('Фамилия',0,0,0,1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' ');
V.WordBasic.EditBookmark('Адрес1',0,0,0,1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address1.AsString + ' ');
V.WordBasic.EditBookmark('Адрес2',0,0,0,1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address2.AsString + ' ');
V.WordBasic.EditBookmark('Адрес3',0,0,0,1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Address3.AsString + ' ');
V.WordBasic.EditBookmark('Заголовок1',0,0,0,1);
V.WordBasic.Insert(Title);
V.WordBasic.EditBookmark('Фамилия1',0,0,0,1);
V.WordBasic.Insert(pnm_data.ContactsQuery1Fam_Name.AsString + ' ');

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

....другое

[000192]


Запуск Word без автостартующего (AutoStart) макроса

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

WordBasic.DisableAutoMacros

Перед выполнением команды не забудьте создать сам объект WordBasic. [000193]


Wordbasic с параметрами из Delphi

Привожу некоторый Delphi код для работы с Word 95. Я протестировал его под Word 97 и, как оказалось, потребовалось внести некоторые исправления - он не захотел работать под ним, но что самое неприятное - после исправлений ошибок выяснилось, что Word 97 работает значительно медленнее, чем Word 95. SendKeys был применен от отчаяния.

Function TAutoMerge.ProcessMerge(FSource, FData, FOutput : string) :
boolean;
var
MSWord  : Variant;
i, NumDocs : integer;
Found : boolean;
s, LastOLECommand : string;
begin
ProcessMerge := False;
try
LastOLECommand := 'Creating OLE Object.';
MSWord := CreateOLEObject('Word.Basic');
LastOLECommand := 'Show MS Word.';
MSWord.AppShow;
Application.ProcessMessages;

LastOLECommand := 'Open document file >' + FSource + '<.';
MSWord.FileOpen(Name := FSource, ConfirmConversions := 0,
ReadOnly := 1, AddToMru := 0, PasswordDoc := '',
PasswordDot := '', Revert := 0,
WritePasswordDoc := '',
WritePasswordDot := '');
LastOLECommand := 'Screen updating = false.';
MSWord.ToolsOptionsSpelling(AutomaticSpellChecking := 0);
LastOLECommand := 'Set background printing to off.';
MSWord.ToolsOptionsPrint(Background := 0);

Application.ProcessMessages;
LastOLECommand := 'Open Data file >' + FData + '<.';
MSWord.MailMergeOpenDataSource(Name := FData, ConfirmConversions := 0,
ReadOnly := 1, LinkToSource := 1,
AddToMru := 0,
PasswordDoc := '', PasswordDot := '',
WritePasswordDoc := '', WritePasswordDot := '',
Connection := '', SQLStatement := '',
SQLStatement1 := '',
Revert := 1);

LastOLECommand := 'Start the Mail Merge.';
MSWord.MailMerge(CheckErrors := 2, Destination := 1,
MergeRecords:= 0,
From := '', To := '', Suppression := 0,
MailSubject := '',
MailAsAttachment := 0, MailAddress := '');

LastOLECommand := 'Set up for SendKeys to select printer.';
Application.ProcessMessages;
MSWord.AppShow;
s := '{home}%l{enter}{home}%n' + FOutput + '{tab}{enter}{home}{enter}';
// sdd 1.1
MSWord.SendKeys(s, -1);
MSWord.MailMergeToPrinter;
Application.ProcessMessages;

ProcessMerge := True;
LastOLECommand := 'All done with merge.';
except
on EOleException do
begin
inc(TotalOLEErrors);
lblStatus.caption := LastOLECommand;
if (TotalOLEErrors >= TOTALOLEERRORS_MAX) then
begin
s := 'Имеется по крайней мере одна ошибка OLE (' +
IntToStr(TotalOLEErrors) +
'), последней ошибкой было >' + LastOLECommand + '<.';
ShowMessage(s);
end;
end
end;
end;

[000194]


Надоел ReportSmith? Хотите, чтобы у вас были WYSIWYG отчеты?

Для вас, которые устали от бесконечных ошибок, проблем, глюков, и других приятных мелочей при работе с ReportSmith, да и просто тому, кому не нравится этот продукт, я посвящаю этот совет. Вам нужен мощный WYSIWYG генератор отчетов?

Хорошо...

Один отличный инструмент для этого вы уже под рукой имеете. Это MS-Word! Вы правы! Используйте Word для генерации отчетов. С использованием OLE Automation это совсем просто. Я могу догадаться, что слово OLE может вас напугать, но попробуйте следующий код:

var
Word: Variant;
begin
Word := CreateOleObject('Word.Basic');
with Word do
begin {Затем следуют "чистые" команды WordBASIC...}
FileNew('Normal');
Insert('Это первая строчка'#13);
Insert('Это вторая строчка'#13);
FileSaveAs('c:\temp\test.txt', 3);
end;
end;

Просто, не правда ли? Как вы наверное уже обратили внимание, нет необходимости пользоваться функциями SendMessage(), PostMessage(), DDE, Word'овским C-API или DOS bat'никами для записи файла. Фактически ничего из перечисленного!

Другое преимущество OLE Automation состоит в том, что оно не требует запуска приложения. Это очень удобно! Вам не нужно искать и запускать EXE-файл. Все делается через WordBASIC. Скоростные характеристики и малый размер расходуемой памяти бьют наповал все методы, указанные в предыдущем абзаце.

Забавным побочным эффектом можно считать визуальность отработки команд OLE Automation, вы видите как все это работает. Да! Word открывает документ, редактирует его согласно вашим командам и все это у вас на глазах.

Все что вам необходимо сделать - это создать шаблон с закладками! Затем, пользуясь командами WordBASIC "EditBookmark .Goto" и "Insert" вы получаете готовый отчет с скомпонованными в нужном месте данными!

Лучшего средства для генерации отчетов не найти. Вы хотели WYSIWYG?

[000195]


Delphi + WordBasic 8

unit oleword;
// Необходима форма и компоненты Memo и Edit на ней.
// Написано для MSWord 8.
// Также необходимо создать тестовый документ d:\test.doc
 interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OLEAuto, ShellAPI, StdCtrls;

type
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
MSWord: Variant;
// WordVersion: Byte;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var Test, Test1:  Integer;
AString: Variant;
begin
MSWord := CreateOLEObject('Word.Application');     //Word 8
MSWord.Documents.Open (FileName:='d:\test.doc', ReadOnly:=True);
MSWord.Visible := 1;         //Закомментарьте, если вы нехотите показывать файл;
Test := MSWord.FontNames.Count;
For Test1 := 1 To Test  do
begin
AString := MSWord.FontNames.Item(Test1) ;
Memo1.Lines.Add(AString);
end;
MSWord.ActiveDocument.Range(Start:=0, End:=0);
MSWord.ActiveDocument.Range.InsertAfter(Text:='Заголовок');
MSWord.ActiveDocument.Range.InsertParagraphAfter;
MSWord.ActiveDocument.Range.Font.Name := 'Arial';
MSWord.ActiveDocument.Range.Font.Size := 24;
AString := MSWord.ActiveDocument.Range.Font.Name;
Edit1.Text := AString;
end;

end.

[000197]


Delphi и OLE Automation с Word

Автоматизация позволяет одному приложению управлять другим приложением. Управляемое приложение называется сервером автоматизации (в нашем случае Word). Приложение, управляющее сервером называется диспетчером автоматизации.

Есть два пути для получения доступа к серверам автоматизации:

Позднее связывание (Интерфейс IDispatch)

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

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

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

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

Раннее связывание (Использование библиотеки типов/интерфейсов)

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

Библиотека типов должна импортироваться в Delphi. Библиотека типов является языковым нейтральным описанием всех объектов и функций, поддерживаемых сервером. (Это подобно файлу заголовка языка C).

При вызове функции должны обязательно присутствовать все параметры, даже те, которые в документации указаны как дополнительные (необязательные). Это позволяет обнаружить и исправить множество ошибок еще до запуска программы.

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

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

Подготовка библиотеки типов.

Модуль Pascal должен быть создан на основе файла библиотеки типов.

    • Выберите пункт меню Project|Import Type Library
    • Нажмите кнопку Add и выберите следующий файл
    • c:\program files\microsoft office\office\msword8.olb
    • Нажмите OK.

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

Наиболее простой путь заключается в следующем: удалите модуль excel_tlb из проекта и только после этого добавьте его в список используемых модулей.

Документация

Справочный файл c:\program files\microsoft office\office\vbawrd8.hlp содержит информацию о доступных объектах Word.

"Записыватель" макросов позволяет быстро создавать VBA-код. После этого он довольно может легко быть портирован в Delphi.

Пример автоматизации

Следующий пример использует класс-оболочку Delphi, инкапсулирующий прямые вызовы объектов Word. Вот преимущество этого метода:

    • Обеспечение скрытия параметров. Возможность использования для многих методов параметров по умолчанию. Многие методы Word также работают с вариантными параметрами. Это означает невозможность использования констант - скрытие параметров решает данную проблему.
    • Обеспечение проверки типа. Многие методы определены с параметрами OLEVariant, обеспечивая внешнюю совместимость.
    • Следующий класс-оболочка демонстрирует ключевые методы автоматизации Word. Полностью класс приведен в Приложении 1.

    unit doc;
interface
uses
windows, sysutils, Word_TLB;
type
TWinWord = class
Private
App : _Application;
public
constructor Create;
destructor Destroy; override;
procedure NewDoc(Template : String);
procedure GotoBookmark(Bookmark : String);
procedure InsertText(Text : String);
procedure SaveAs(Filename : string);
end;

//------------------------------------------------------------------

implementation

//------------------------------------------------------------------

constructor TWinWord.Create;
begin
App := CoApplication.Create;
end;

//------------------------------------------------------------------

destructor TWinWord.Destroy;
var
SaveChanges : OLEVariant;
OriginalFormat : OLEVariant;
RouteDocument : OLEVariant;
begin
SaveChanges := wdDoNotSaveChanges;
OriginalFormat := unAssigned;
RouteDocument := unAssigned;
app.Quit(SaveChanges, OriginalFormat, RouteDocument);
inherited destroy;
end;

//------------------------------------------------------------------

procedure TWinWord.GotoBookmark(Bookmark : string);
var
What : OLEVariant;
Which : OLEVariant;
Count : OLEVariant;
Name : OLEVariant;
begin
What := wdGoToBookmark;
Which := unAssigned;
Count := unAssigned;
Name := Bookmark;
App.Selection.GoTo_(What, Which, Count, Name);
end;

//------------------------------------------------------------------

procedure TWinWord.InsertText(Text : String);
begin
App.Selection.TypeText(Text);
end;

//------------------------------------------------------------------

procedure TWinWord.NewDoc(Template : String);
var
DocTemplate : OleVariant;
NewTemplate : OleVariant;
begin
DocTemplate := Template;
NewTemplate := False;
App.Documents.Add(DocTemplate, NewTemplate);
end;

//------------------------------------------------------------------

procedure TWinWord.SaveAs(Filename : string);
begin
OLEVariant(App).ActiveDocument.SaveAs(FileName);
end;

//------------------------------------------------------------------

end.

Чтобы создать класс:

Добавьте модуль библиотеки типов в список используемых модулей.
    uses
windows, sysutils, Word_TLB;

Создадим определение класса:
    TWinWord = class
Private
App : _Application;
public
procedure NewDoc(Template : String);
procedure GotoBookmark(Bookmark : String);
procedure InsertText(Text : String);
procedure SaveAs(Filename : string);
constructor Create;
destructor Destroy; override;
end;

Переменная App является ссылкой на приложение Word. Это допускает вызов методов Word с применением технологии раннего связывания.

Опубликованные (public) процедуры - процедуры, которые могут быть использованы при работе с классом.

Создадим конструктор.
    constructor TWinWord.Create;
begin
App := CoApplication.Create;
end;

Он вызывается при создании класса TWinWord. CoApplication.create создает новый экземпляр Word и возвращает ссылку на интерфейс Application. Это позволяет вызывать методы объекта app.

Реализация дектруктора
    destructor TWinWord.Destroy;
var
SaveChanges : OLEVariant;
OriginalFormat : OLEVariant;
RouteDocument : OLEVariant;
begin
SaveChanges := wdDoNotSaveChanges;
OriginalFormat := unAssigned;
RouteDocument := unAssigned;
app.Quit(SaveChanges, OriginalFormat, RouteDocument);
inherited destroy;
end;

Деструктор должен вызываться В ОБЯЗАТЕЛЬНОМ ПОРЯДКЕ. Метод Quit объекта приложения закрывает Word и распределяет всю связанную с ним память. Так как параметры метода Quit определены как вариантный тип OLEVariant, вся свазанная с ними память распределяется именно для этого типа переменных.

Реализуем метод NewDoc. Этот метод создаст новый текстовый документ на основе заданного шаблона.
    procedure TWinWord.NewDoc(Template : String);
var
DocTemplate : OleVariant;
NewTemplate : OleVariant;
begin
DocTemplate := Template;
NewTemplate := False;
App.Documents.Add(DocTemplate, NewTemplate);
end;

Данный метод осуществляет более строгую проверку типов, чем это осуществляет сам Word. Параметр Template должен содержать строку с именем шаблона. Метод Word Add в качестве параметров может содержать значения любого типа. Лучшая пример этого - метод MoveRight, реализация которого показана в Приложении 1.

Ниже показана реализация метода SaveAs. Данный метод позволит сохранить в файле текущий документ.
    procedure TWinWord.SaveAs(Filename : string);
begin
OLEVariant(App).ActiveDocument.SaveAs(FileName);
end;

Данный пример использует позднее связывание. В результате имя метода и используемые типы проверяются только во время прогона. Изменение имени метода в этом случае не вызовет ошибку во время компиляции. В нашем случае технология позднего связывания более эффективна, так как метод SaveAs требует 12 параметров, но только параметр FileName является обязательным. Так как данный вызов можно считать единичным, его выполнение не может особо сказаться на скорости выполнения программы.

Следующий код демонстрирует использование данного класса для создания, редактирования, печати и сохранения документа, созданного на основе шаблона:
    Word := TWinWord.create;
try
Word.visible := true;
Word.NewDoc('c:\delphi\word\sample\Demo');
Word.GotoBookmark('From');
Word.InsertText('Иван Иваныч');
Word.GotoBookmark('Dept');
Word.InsertText('Разработка');
Word.GotoBookmark('Phone');
Word.InsertText('111111');
Word.GotoBookmark('Now');
Word.InsertText(FormatDateTime('d-mmm-yyyy', now));
//SF элементы
Word.GotoBookmark('Items');
Word.InsertText('112021');
Word.MoveRight(1);
Word.InsertText('PVCS');
Word.MoveRight(1);
Word.InsertText('1');
Word.MoveRight(1);
Word.InsertText('Ј 305.99');
Word.MoveRight(1);
Word.InsertText('Ј 305.99');
Word.MoveRight(1);
Word.UpdateFields;
Word.RunMacro('Demo');
Word.Print;
Word.SaveAs(filename);
finally
Word.Free;
end;

Итог

  • Всегда используйте раннее связывание.
  • Если позднее связывание необходимо для вызовов некоторых функций, используйте где возможно раннее связывание и преобразование типа объектной переменной к типу OLEVariant для вызовов, требующим позднее связывание.
  • Не включайте модуль библиотеки типов в ваш проект. Добавьте его только в список используемых модулей.
  • Создавайте код автоматизации в отдельном модуле. Инкапсулируйте вызовы в классе-оболочке.
  • Используйте "записыватель" макросов Word для создания прототипа кода автоматизации.
  • Используйте файл электронной справки vbawrd8.hlp для получения информации об объектах Word.
  • Используйте модуль Word_tlb.pas для проверки необходимых Delphi типов и количества параметров. Для проверки правильности кода перекомпилируйте проект, нажав клавиши <CTRL><F9>.
  • Загружайте и используйте шаблоны Word, содержащие предварительное форматирование текста. Этот способ существенно быстрее и не требует большого времени для создания сложноформатированных документов. Шаблоны ДОЛЖНЫ сохраняться приложением в своей рабочей директории. Это поможет избежать проблем, связанных с конфликтом имен.
  • Используйте закладки (Bookmarks) для определения области ввода текста приложением Delphi.
  • Удостоверьтесь в том, что ваш код содержит команду закрытия приложения Word (app.quit). Не вызывая app.quit, можно быстро исчерпать системные ресурсы, особенно при работе с большим количеством документов Word. Обратите на это особое внимание.
  • Наличие множества незакрытых документов Word легко проверить в Windows NT, используя Менеджер Задач (нажмите CTL+ALT+Del для его открытия).

Приложение A – Полный исходный код сласса TWinWord

Полный исходный код класса tWinWord приведен ниже. Он включает реализацию всех методов:
    unit doc;
interface
uses
Word_TLB, windows, sysutils;
Type
TWinWord = class
Private
App : _Application;
function fGetVisible : boolean;
procedure fSetVisible(visible : boolean);
public
procedure NewDoc(Template : String);
procedure GotoBookmark(Bookmark : String);
procedure InsertText(Text : String);
procedure MoveRight(Count : integer);
procedure Print;
procedure UpdateFields;
procedure SaveAs(Filename : string);
Procedure RunMacro(MacroName : string);
constructor Create;
destructor Destroy; override;
property visible : boolean
read fGetVisible
write fSetVisible;
end;

implementation

//------------------------------------------------------------------

constructor TWinWord.Create;
begin
App := CoApplication.Create;
end;

//------------------------------------------------------------------

destructor TWinWord.Destroy;
var
SaveChanges : OLEVariant;
OriginalFormat : OLEVariant;
RouteDocument : OLEVariant;
begin
SaveChanges := wdDoNotSaveChanges;
OriginalFormat := unAssigned;
RouteDocument := unAssigned;
app.Quit(SaveChanges, OriginalFormat, RouteDocument);
inherited destroy;
end;

//------------------------------------------------------------------

function TWinWord.fGetVisible : boolean;
begin
result := App.Visible;
end;

//------------------------------------------------------------------

procedure TWinWord.fSetVisible(Visible : boolean);
begin
App.visible := Visible;
end;

//------------------------------------------------------------------

procedure TWinWord.GotoBookmark(Bookmark : string);
var
What : OLEVariant;
Which : OLEVariant;
Count : OLEVariant;
Name : OLEVariant;
begin
What := wdGoToBookmark;
Which := unAssigned;
Count := unAssigned;
Name := Bookmark;
App.Selection.GoTo_(What, Which, Count, Name);
end;

//------------------------------------------------------------------

procedure TWinWord.InsertText(Text : String);
begin
App.Selection.TypeText(Text);
end;

//------------------------------------------------------------------

procedure TWinWord.NewDoc(Template : String);
var
DocTemplate : OleVariant;
NewTemplate : OleVariant;
begin
DocTemplate := Template;
NewTemplate := False;
App.Documents.Add(DocTemplate, NewTemplate);
end;

//------------------------------------------------------------------

procedure TWinWord.MoveRight(Count : integer);
var
MoveUnit : OleVariant;
vCount : OleVariant;
Extended : OleVariant;
begin
MoveUnit := wdCell;
vCount := Count;
Extended := unassigned;
app.selection.MoveRight(MoveUnit, vCount, Extended);
end;

//------------------------------------------------------------------

procedure TWinWord.Print;
begin
OLEVariant(app).Printout;
end;

//------------------------------------------------------------------

procedure TWinWord.UpdateFields;
begin
App.ActiveDocument.Fields.Update;
end;

//------------------------------------------------------------------

procedure TWinWord.SaveAs(Filename : string);
begin
OLEVariant(App).ActiveDocument.SaveAs(FileName);
end;

//------------------------------------------------------------------

procedure TWinWord.RunMacro(MacroName : string);
begin
App.Run(MacroName);
end;

//------------------------------------------------------------------

end.

[000199]


Delphi 1

Вызов MS Word из Delphi

ShellExecute(0, nil, 'c:\data\word\sample1.doc', nil,
nil, SW_SHOWNORMAL);

Не забудьте включить ShellAPI в список используемых модулей. [000552]


Delphi 1

WinWord через DDE

Кто-нибудь пробовал использовать WinWord в качестве DDE-сервера? Поделитесь результатами, если они, конечно, успешны.

Опыт 1

Пара других пользователей также задавала на этой неделе аналогичный вопрос, но у меня не было доступа к машине, где установлена Delphi. К несчастью я затер их адреса, но надеюсь они увидят это сообщение. Нижеприведенный код является "экстрактом" моей технологии, которую я успешно применил для создания DDEPokes и DDEExecutes с WinWord в качестве сервера. Обратите внимание на то, что я использовал методы DDE, требующие PChar вместо строк, поскольку строки имеют дополнительные символы и при DDE-преобразованиях WinWord'у плохеет.

function TfrmLetter.CreateLetter: Boolean;
var
szCommand: Array[0..2048] of char;
sCommand: String;
BmkNames: array[0..3] of String;
idx: ShortInt;
DDEOK: Boolean;
Buffer, ParMark: PChar;
BufSize: Integer;
hWord: hWnd;
begin
CreateLetter := False;
DDEOK := True; {Флаг проверки результатов DDE-операций}
DDEClient.SetLink('winword',WordDoc); {WordDoc содержит имя документа winword, необходимого для связи}
{DDEClient - элемент управления DDE client}
if DDEClient.OpenLink = False then Exit;

hWord := FindWindow('OpusApp', nil);
LockWindowUpdate(hWord); {Блокируем обновление экрана winword}

{Убедитесь, что нужный документ является активным окном Word}
sCommand := '[If FileName$() <> "' + WordDoc + '" Then]';
sCommand := sCommand + '[While (idx < CountWindows()) and (FileName$() <> "';
sCommand := sCommand + WordDoc + '")][NextWindow][idx = idx + 1]';
sCommand := sCommand + '[Wend][Activate WindowName$()][End If]';
StrPLCopy(szCommand,sCommand, SizeOf(szCommand) - 1);
DDEOK := DDEOK and DDEClient.ExecuteMacro(szCommand, False);

{Сбрасываем баннер}
sCommand := '[EditGoto "Banner"]';
If GetWinwordVersion = 2 then {GetWinword - простая функция пользователя, использующая GetModuleHandle для определения номера версии запущенного Word: Word 2 или Word 6}
sCommand := sCommand + '[EditGlossary "Banner"]'
Else If GetWinwordVersion = 6 then
sCommand := sCommand + '[EditAutoText "Banner"]';
sCommand := sCommand + '[EditGoto "Date"][UpdateFields][LockFields]';
StrPLCopy(szCommand,sCommand, SizeOf(szCommand) - 1);
DDEOK := DDEOK and DDEClient.ExecuteMacro(szCommand, False);
Application.ProcessMessages;

{Вставляем Имя отправителя, Прямой номер абонента и пр.}
BmkNames[0] := 'DirectDialNumber';
BmkNames[1] := 'EMailAddress';
BmkNames[2] := 'AuthorName';
BmkNames[3] := 'Personal';
For idx := 0 To 3 do
if CheckInclude[idx].Checked = True then
begin
BufSize := TextInclude[idx].GetTextLen;
Inc(BufSize);
GetMem(Buffer, BufSize);
TextInclude[idx].GetTextBuf(Buffer,BufSize);
DDEOK := DDEOK and DDEClient.PokeData(BmkNames[idx], Buffer);
FreeMem(Buffer, BufSize);
end
else
DDEOK := DDEOK and DDEClient.PokeData(BmkNames[idx] + '2', '');

и так далее.

--gpm

Опыт 2

Вот еще очень простой пример DDE-связи с WinWord 6. Это работает.

В Word вы должны иметь заранее созданный файл (в нашем примере DDETEST.DOC) и закладку с именем "Bm1".

{------------------- полный исходный код --------------------------}
unit Unit1;

interface

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

type
TForm1 = class(TForm)
DdeConv: TDdeClientConv;
Word: TButton;
procedure WordClick(Sender: TObject);
private
{ Private-declarations }
public
{ Public-declarations }
end;

{  Свойства DdeConv:       }
{  ConnectMode : ddeManual }
{  DdeService : [None]     }
{  DdeTopic    : [None]    }
{  FormatChars : False     }
{  Name        : DdeConv   }
var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WordClick(Sender: TObject);
begin
if DdeConv.SetLink( 'WINWORD', 'D:\WINWORD\DDETEST' ) and
DdeConv.OpenLink then
begin
ShowMessage( 'Установлена связь с WinWord !' )  { убедимся в наличии соединения }
DdeConv.PokeData( 'Bm1', 'Данные из Delphi !' ) { вставляем 'Данные из Delphi' в документ word }
DdeConv.CloseLink ;
end ;
end;

end.
{------------------- конец исходного кода --------------------}

Но только сделав это хотя бы раз своими руками, вы сможете разобраться в этой технологии!

Jean-Yves [000570]


Excel

Подскажите мне основные функции OLE Automation для работы с Excel из Delphi.

Есть множество статей по этому вопросу. Смотри также материал по адресу http://vzone.virgin.net/graham.marshall/excel.htm#excel.htm.

Я не могу привести полный код моего проекта, здесь я поместил лишь его небольшую часть, создающую и форматирующую таблицу Excel на основе содержимого DBGrid, сгенеренного с помощью SQL запроса. Код содержит некоторое форматирование ячеек. Код проверен в работе с Delphi 3 и Excel 97:

procedure TfrmBlank.btnExcelClick(Sender: TObject);
var
XL, XArr: Variant;
i : Integer;
j : Integer;
begin
{не забудьте включить ComObj в список используемых модулей}
// Создаем массив элементов, полученных в результате запроса
XArr:=VarArrayCreate([1,EmailQuery.FieldCount],varVariant);
XL:=CreateOLEObject('Excel.Application');     // Создание OLE объекта
XL.WorkBooks.add;
XL.visible:=true;

j := 1;
EmailQuery.First;
while not EmailQuery.Eof do begin
i:=1;
while i<=EmailQuery.FieldCount do begin
XArr[i] := EmailQuery.Fields[i-1].Value;
i := i+1;
end;
XL.Range['A'+IntToStr(j),
CHR(64+EmailQuery.FieldCount)+IntToStr(j)].Value := XArr;
EmailQuery.Next;
j := j + 1;
end;
XL.Range['A1',CHR(64+EmailQuery.FieldCount)+IntToStr(j)].select;
// XL.cells.select;                     // Выбираем все
XL.Selection.Font.Name:='Garamond';
XL.Selection.Font.Size:=10;
XL.selection.Columns.AutoFit;
XL.Range['A1','A1'].select;
end;

Дополнение

При однопроходной передачи полной страницы гораздо удобнее использовать двумерный Variant Array, чем запихивать данные туда построчно. Функция VarArrayCreate позволяет создать многомерные массивы при определении 2N (где N - кол-во измерений) границ массива в аргументе Bounds.

Konstantin Khripkov [000196]


Delphi и OLE Automation с Excel

Автоматизация позволяет одному приложению управлять другим приложением. Управляемое приложение называется сервером автоматизации (в нашем случае Excel). Приложение, управляющее сервером называется диспетчером автоматизации.

Есть два пути для получения доступа к серверам автоматизации:

Позднее связывание (Интерфейс IDispatch)

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

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

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

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

Раннее связывание (Использование библиотеки типов/интерфейсов)

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

Библиотека типов должна импортироваться в Delphi. Библиотека типов является языковым нейтральным описанием всех объектов и функций, поддерживаемых сервером. (Это подобно файлу заголовка языка C).

При вызове функции должны обязательно присутствовать все параметры, даже те, которые в документации указаны как дополнительные (необязательные). Это позволяет обнаружить и исправить множество ошибок еще до запуска программы.

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

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

Подготовка библиотеки типов.

Модуль Pascal должен быть создан на основе файла библиотеки типов.

Выберите пункт меню Project|Import Type Library.

Нажмите кнопку Add и выберите следующий файл

c:\program files\microsoft office\office\excel8.olb

Нажмите OK.

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

Наиболее простой путь заключается в следующем: удалите модуль excel_tlb из проекта и только после этого добавьте его в список используемых модулей.

Документация

Справочный файл c:\program files\microsoft office\office\vbaxl8.hlp содержит информацию о доступных объектах Excel.

"Записыватель" макросов позволяет быстро создавать VBA-код. После этого он довольно может легко быть портирован в Delphi.

Пример автоматизации

Код следующего примера демонстрирует создание простой электронной таблицы и наполнение ее данными. Не забудьте добавить excel_tlb в список используемых модулей.

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

Unit sheet;

//--------------------------------------------------------------------

interface

//--------------------------------------------------------------------

uses
windows, sysutils, excel_tlb;

Procedure CreateSpreadsheet;

//--------------------------------------------------------------------

implementation

//--------------------------------------------------------------------

Procedure CreateSpreadsheet(filename : string);
var
xla : _Application;
xlw : _Workbook;
LCID : integer;
begin
xla := CoApplication.Create;
LCID := GetUserDefaultLCID;
try
xla.Visible[LCID] := true;
// пустая книга
//xlw := xla.Workbooks.Add(xlWBATWorksheet, LCID);
// новая книга на основе шаблона
xlw := xla.Workbooks.Add(
'c:\delphi\excel\sample\demo.xlt',
LCID);
xla.Range['A1', 'A1'].Value := 'Date';
xla.Cells[1, 2].Value := FormatDateTime('dd-mmm-yyyy', Now);
xla.Cells[3, 1].Value := 'Numbers';
xla.Range['B3', 'E3'].Value := VarArrayOf([1, 10, 100, 1000]);
xla.Range['F3', 'F3'].Formula := '=Sum(B3:E3)';
OLEVariant(xla).Run(
'Demo',
FormatDateTime('dd-mmm-yyyy', Now)
);
xlw.SaveAs(
filename,
xlWorkbookNormal,
'','',False,False,
xlNoChange,
xlLocalSessionChanges,
true,0,0,LCID);
finally
xla.Quit;
end;
end;
//--------------------------------------------------------------------

end.

Добавьте библиотеку типов в список используемых молулей.

uses
windows, sysutils, excel_tlb;

Первая строчка кода создает объект Excel приложения.

xla := CoApplication.Create;

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

LCID := GetUserDefaultLCID;

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

Примечание: Для вызова этой функции необходим параметр LCID. К сожалению этот факт умалчивается в электронной документации по Excel. В файле c:\program files\borland\Delphi 3\imports\excel_tlb.pas наглядно видны свойства функций и определения методов.

xla.visible[LCID] := true;

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

xlw := xla.Workbooks.Add('c:\delphi\excel\sample\demo.xlt', LCID);

Примечание: Вам вовсе не обязательно подставлять файл шаблона Excel (.xlt), но все же это наилучший способ для форматирования информации. Чем больше сделано с помощью Excel, тем меньше придется делать с помощью Delphi. На данный момент это является лидирующей технологией.

Для создания пустой книги используйте:

xlw := xla.Workbooks.Add(xlWBATWorksheet, LCID);

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

xla.Range['A1', 'A1'].Value := 'Date';
xla.Cells[1, 2].Value := FormatDateTime('dd-mmm-yyyy', Now);

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

xla.Range['A2', 'D2'].Value := VarArrayOf([1, 10, 100, 1000]);

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

xla.Range['E2', 'E2'].Formula := '=Sum(a2:d2)';

Следующая строка кода выполняет VBA функцию, хранящуюся в файле шаблона. На первый взгляд все выглядит достаточно сложно, но это только кажется. Преобразование типа xla к OLEVariant позволяет вызвать функцию, используя позднее, а не раннее связывание. (Причина в имени метода и параметрах, решаемых только во время прогона программы, а никак во время разработки). Delphi просто не знает количество и тип параметров, передаваемых макросу ‘Demo’.

OLEVariant(xla).Run(
'Demo',
FormatDateTime('dd-mmm-yyyy', Now));

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

xlw.SaveAs(
filename,
xlWorkbookNormal,
'', '',False,False,
xlNoChange, xlLocalSessionChanges,
true, 0, 0, LCID);

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

xla.quit;

Итог

  • Всегда используйте раннее связывание.
  • Если позднее связывание необходимо для вызовов некоторых функций, используйте где возможно раннее связывание и преобразование типа объектной переменной к типу OLEVariant для вызовов, требующим позднее связывание.
  • Не включайте модуль библиотеки типов в ваш проект.
  • Создавайте код автоматизации в отдельном модуле.
  • Используйте "записыватель" макросов Excel для создания прототипа кода автоматизации.
  • Используйте файл электронной справки vbaxl8.hlp для получения информации об объектах Excel.
  • Используйте модуль excel_tlb.pas для проверки необходимых Delphi типов и количества параметров.
  • Загружайте и используйте шаблоны Excel (.xlt файлы), содержащие предварительное форматирование и связывание данных. Этот способ существенно быстрее и не требует большого времени для создания форматированных электронных таблиц. Шаблоны ДОЛЖНЫ сохраняться приложением в своей рабочей директории. Это поможет избежать проблем, связанных с конфликтом имен. Файлы шаблонов могут также содержать макросы, которые могут быть вызваны из приложений Delphi.
  • Удостоверьтесь в том, что ваш код содержит команду закрытия приложения Excel (xla.quit). Не вызывая xla.quit, можно быстро исчерпать системные ресурсы, особенно при работе с большим количеством документов Excel.
  • Наличие множества незакрытых документов Excel легко проверить в Windows NT, используя Менеджер Задач (нажмите CTL+ALT+Del для его открытия).
  • В больших электронных таблицах повысить быстродействие вам поможет обработка ячеек посредством "мультикоманды", оперирующей одновременно множеством ячеек. Это также улучшит читаемость кода.

Приложение A – Быстродействие

Тестирование производилось на компьютере P166 с 64Мб памяти. Первоначальная инициализация приложения не производилась. Это гарантировало, что Excel при загрузке пользовался диском, а не кэшем. Первоначальная инициализация существенно уменьшила бы скорость загрузки приложения. В реальной ситуации процесс загрузки занимает около 5 секунд.

Тест включал в себя загрузку числовых данных в чистую электронную таблицу размером 10 колонок на n строк. Для вычисления быстродействия использовались следующие три метода:

  • Заполнение листа ячейка за ячейкой.
  • Заполнение одной колонки за один проход.
  • Заполнение всей таблицы за один проход.

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

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

Размер электронной таблицы (строки * колонки) | Заполнение ячейка за ячейкой | Заполнение одной колонки за один проход | Заполнение всей таблицы за один проход
10 * 10 | 0:01 | 0:01 | >0:01
100 * 10 | 0:07 | 0:01 | 0:01
1000 * 10 | 1:13 | 0:07 | 0:05
5000 * 10 | 5:22 | 0:35 | 0:25
Приблизительно ячейки/секунды | 150 | 1500 | 2000

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

Большие таблицы эффективно заполнять колонка за колонкой.

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

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

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

Использованные для тестов процедуры:

//-----------------------------------------------------------------------

procedure FillByCell;
var
xla : _Application;
xlw : _Workbook;
LCID : integer;
i,j : integer;
begin
xla := CoApplication.Create;
LCID := GetUserDefaultLCID;
try
xlw := xla.Workbooks.Add(xlWBATWorksheet, LCID);
for i:=1 to ROWS do begin
for j:=1 to 10 do begin
xla.Cells[i,j] := i+j;
end;
end;
xlw.close(false, '', false, LCID);
finally
xla.Quit;
end;
end;

//-----------------------------------------------------------------------

procedure FillByRow;
var
xla : _Application;
xlw : _Workbook;
CellFrom : string;
CellTo : string;
i,j : integer;
Row : array[1..10] of variant;
LCID : integer;
begin
xla := CoApplication.Create;
LCID := GetUserDefaultLCID;
try
xlw := xla.Workbooks.Add(xlWBATWorksheet, LCID);
for i:=1 to ROWS do begin
for j:=1 to 10 do begin
Row[j] := i+j;
end;
CellFrom := 'A' + InttoStr(i);
CellTO := 'J' + InttoStr(i);
xla.Range[CellFrom, CellTo].Value := VarArrayOf(Row);
end;
xlw.close(false, '', False, LCID);
finally
xla.Quit;
end;
end;

//-----------------------------------------------------------------------

procedure FillBySheet;
var
xla : _Application;
xlw : _Workbook;
CellFrom : string;
CellTo : string;
i,j : integer;
range : Variant;
row : array [1..10] of Variant;
LCID : integer;
begin
xla := CoApplication.Create;
LCID := GetUserDefaultLCID;
try
xlw := xla.Workbooks.Add(xlWBATWorksheet, LCID);
Range := VarArrayCreate([1, ROWS], varVariant);
for i:=1 to ROWS do begin
for j:=1 to 10 do begin
row[j] := i+j;
end;
Range[i] := VarArrayOf(row);
end;
CellFrom := 'A' + InttoStr(1);
CellTO := 'J' + InttoStr(ROWS);
xla.Range[CellFrom, CellTo].FormulaArray := Range;
xlw.close(false, '', False, LCID);
finally
xla.Quit;
end;
end;

Приложение 2 – Использование в Delphi класса-оболочки

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

unit sheet;

interface

uses
EXCEL_TLB, windows, sysutils;

//-------------------------------------------------------------------------

type
tExcel = class
private
xla : _Application;
xlw : _Workbook;
LCID : integer;
procedure fSetVisible(Visible : boolean);
function fGetVisible : boolean;
procedure fSetCell(Cell : string; Value : OLEVariant);
function fGetCell(Cell : string) : OleVariant;
public
constructor create;
destructor destroy; override;
procedure AddWorkBook(Template : OleVariant);
procedure SaveAs(filename : string);
property Visible : boolean
read fGetVisible write fSetVisible;
property Cell[Cell : string] : OleVariant
read fGetCell write fSetCell;
end;

//-------------------------------------------------------------------------

Procedure CreateSpreadsheet(filename : string);

//-------------------------------------------------------------------------

implementation

//-------------------------------------------------------------------------

constructor tExcel.create;
begin
LCID := GetUserDefaultLCID;
xla := CoApplication.Create;
end;

//-------------------------------------------------------------------------

destructor tExcel.destroy;
begin
xla.Quit;
inherited;
end;

//-------------------------------------------------------------------------

procedure tExcel.AddWorkBook(Template : OleVariant);
begin
xlw := xla.Workbooks.Add(Template, LCID);
end;

//-------------------------------------------------------------------------

procedure tExcel.fSetVisible(Visible : boolean);
begin
xla.visible[lcid] := Visible;
end;

//-------------------------------------------------------------------------

function tExcel.fGetVisible : boolean;
begin
result := xla.visible[lcid];
end;

//-------------------------------------------------------------------------

procedure tExcel.fSetCell(Cell : string; Value : OLEVariant);
begin
xla.Range['A1', 'A1'].Value := value;
end;

//-------------------------------------------------------------------------

function tExcel.fGetCell(Cell : string) : OleVariant;
begin
result := xla.Range['A1', 'A1'].Value;
end;

//-------------------------------------------------------------------------

procedure tExcel.SaveAs(filename : string);
begin
xlw.SaveAs(
filename,
xlWorkbookNormal,
'',
'',
False,
False,
xlNoChange,
xlLocalSessionChanges,
true,
0,
0,
LCID);
end;

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

Procedure CreateSpreadsheet(filename : string);
var
xl : tExcel;
begin
xl := tExcel.create;
try
xl.AddWorkBook('c:\graham\excel\sample2\ssddemo.xlt');
xl.visible := true;
xl.cell['a1'] := 'тест';
xl.SaveAs(filename);
finally
xl.free;
end;
end;
[000198]


Пересылка данных в ячейки Excel

Mikhail Andronov советует:

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

Привожу полностью все файлы проекта:

Main.dfm

object Form1: TForm1
Left = 267
Top = 137
AutoScroll = False
Caption = 'Экспорт результатов SELECT в Excel'
ClientHeight = 277
ClientWidth = 519
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 8
Top = 4
Width = 114
Height = 13
Caption = 'Предложение SELECT'
end
object Label2: TLabel
Left = 8
Top = 224
Width = 91
Height = 13
Caption = 'Имя базы данных'
end
object btnExport: TButton
Left = 436
Top = 20
Width = 75
Height = 25
Caption = 'Экспорт'
TabOrder = 0
OnClick = btnExportClick
end
object memSelect: TMemo
Left = 8
Top = 20
Width = 417
Height = 197
TabOrder = 1
end
object edtDatabaseName: TEdit
Left = 8
Top = 240
Width = 413
Height = 21
TabOrder = 2
end
object queSelect: TQuery
Left = 24
Top = 20
end
end

Main.pas

unit Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Db, DBTables;

type
TForm1 = class(TForm)
queSelect: TQuery;
btnExport: TButton;
memSelect: TMemo;
edtDatabaseName: TEdit;
Label1: TLabel;
Label2: TLabel;
procedure btnExportClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
ComObj;
{$R *.DFM}

procedure TForm1.btnExportClick(Sender: TObject);
var
XL, // Приложение Excel
TableVals : Variant;  // Врем. массив для переноса значений в Excel
i, LineCounter,       // Счетчик строк для переноса записей в Excel
queSelectRecCount,
queSelectFieldsCount : Integer;
begin
inherited;
try
Application.ProcessMessages;
Screen.Cursor := crSQLWait;

with queSelect do
begin
SQL.Assign(memSelect.Lines);
DatabaseName := edtDatabaseName.Text;
Open;
{AMA: Экспорт в Excel}
queSelectRecCount := RecordCount;
queSelectFieldsCount := FieldCount;
TableVals := VarArrayCreate([0, queSelectRecCount-1,//кол-во строк
0, queSelectFieldsCount-1], // кол-во столбцов
varOleStr);

First;
LineCounter := 0;
while not EOF do
begin
for i := 0 to queSelectFieldsCount-1 do
if not Fields[i].IsNull then
TableVals[LineCounter, i] := Fields[i].AsString
else
TableVals[LineCounter, i] := '';
LineCounter := LineCounter + 1;
Next;
end;
Close;
end;

try
try
XL := GetActiveOleObject('Excel.Application');
except
XL := CreateOleObject('Excel.Application');
end;
except
raise Exception.Create('Не могу запустить Excel');
end;

XL.Visible := True;
XL.Workbooks.Add;
XL.Range[XL.Cells[1,1],
XL.Cells[queSelectRecCount,
queSelectFieldsCount]].Value := TableVals;
XL.Range[XL.Cells[1,1],
XL.Cells[queSelectRecCount,
queSelectFieldsCount ]].Borders.Weight := 2;
finally
Screen.Cursor := crDefault;
end;
end;

end.

SelectToExcel.dpr

program SelectToExcel;

uses
Forms,
Main in 'Main.pas' {Form1};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

[000845]


MAPI и MS Exchange

Используйте для регистрации:

MapiLogon(application.handle,nil,nil,mapi_use_default,0,@mapihandle)

Чтобы послать сообщение:

MapiSendMail(mapihandle, 0,MapiMessage,0, 0);

Убедитесь, что поля SUBJECT, RECIP и NOTTEXT в структуре MapiMessage заполнены, в противном случае сообщение отправлено не будет.

Также, с помощью API функции GetWindowHandle, необходимо убедиться в том, что Exchange запущен, в противном случае для запуска клиента используйте ShellExecute. [000311]


Delphi 2

Проблемы со шрифтами у QuickReport

Я использую Delphi 2.0 и QuickReports 1.1.

Я создал ОЧЕНЬ сложный (графически, во всяком случае) отчет и только что обнаружил, что это не выводится как положено на экране и на принтере во время выполнения программы (хотя это и корректно отображается в окне предварительного просмотра в режиме проектирования). Ошибка возникает только в том случае, если в Windows 95 установлены большие (LARGE) системные шрифты! Ну и что мне теперь прикажете делать?

У меня тоже была такая же серьезная проблема, но только при печати под Win 95 на офисный HP 4M и при просмотре отчета под NT 4.0. Но то же самое приложение у меня прекрасно работало под NT 3.51 SP5.

Я видел дискуссию по поводу этой ошибки, возникающей в GDI коде под NT 4.0, поэтому я не удивился, обнаружив ее у себя. Мне пришлось засучить рукава и очень тесно познакомиться с кодом QuickReports, особенно с процедурой первичного вывода текста, когда программа изменяет шрифт в каждой выводимой области. Вот этот злосчастный сегмент кода в методе TQRCustomControl.Print:

QRPrinter.Canvas.Font:=Font;
QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size)));
QRPrinter.Canvas.brush.Color:=Color;

Теперь те из нас, которые истратили слишком много времени на изучение исходного кода VCL узнали, что VCL поддерживает кэш ресурса через менеджера дескрипторов в Graphics.pas и что попытки уменьшения количества используемых ресурсов Windows сводятся к методу подсчета ссылок на дескрипторы многократно испольуемых ресурсов. Коду, приведенному выше, отлично удалось это обойти! Каждый раз холст принтера устанавливает шрифты полей, таким образом уменьшая счетчик используемых ресурсов в ноль с дальнейшим его освобождением и затем масштабирует размер шрифта для соответствия его метрике принтера, таким образом требуя размещения нового шрифтового ресурса.

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

В качестве эксперимента я создал непечатаемую этикетку с тем же самым размером шрифта, что и у масштабируемого шрифта принтера, тем самым заставляя ресурс кэшироваться - ошибка исчезла как страшный сон! Это доказывает идентичность проблемы в NT 4.0 - те же действующие лица: регистратор расширенных метафайлов и огромное количество изменений шрифтов.

Лучшее решение я увидел в следующем:

// При установке нового шрифта сохраняем шрифт принтера
SaveFont := TFont.Create;
SaveFont.Assign(QRPrinter.Canvas.Font);

QRPrinter.Canvas.Font:=Font;
QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size)));
QRPrinter.Canvas.brush.Color:=Color;

// Освобождаем сохраненный шрифт принтера. Теперь работа сделана.
SaveFont.Free;
SaveFont := nil;

Дополнительными строками нам удается проверить тот факт, что шрифт принтера уже используется или же для холста принтера выбирается тот же самый шрифт. Это работает уже вполне корректно и позволяет печатать правильные отчеты под NT 4.0. Некоторым странным совпадением можно считать устранение зашитых жирных шрифтов, изменившее шрифты, печатаемые под Win95.

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

[000217]


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

Попробуйте сделать следующее:

QRPrinter.PreviewCaption := 'Мой заголовок';

QRPrinter - глобальная переменная, определенная в модуле Quickrep.pas [000218]


Переключение принтеров при печати в QuickReport

Привет! Кто-нибудь пристально изучал объект TPrinter?
Вы можете задать необходимый для печати принтер, используя свойство Printer.PrinterIndex.
Для примера:

Printer.PrinterIndex:=0; // Устанавливает первый принтер, проинсталлированный в системе
Printer.PrinterIndex:=-1; // Указывает на принтер, установленный в системе по умолчанию

И все! Не нужно никаких Win API функций и глобальных переменных!

[000219]


Передача переменных отчета в ReportSmith I

Я имею проблему с передачей id клиента в reportsmith для печати специфического отчета мастер/деталь. Я не нахожу способа каким образом можно передать значение id переменной отчета. Как мне передать ее из Delphi в ReportSmith?

В свое время эта проблема также попортила мне немало нервов, но наконец-то я могу похвастаться ее решением:

begin
MillCardNewRep.InitialValues.Clear;
{Передаем Current Milling Number
(текущий номер поля Milling) в ReportSmith}
MillCardNewRep.InitialValues.Add('@MILLING=<'+MillingNoEdit.Text+'>')
MillCardNewRep.Run;
end;

Я объявил переменную MILLING в отчете RS как число, получаемое из компонента DBEdit.

НО

обратите внимание что из Delphi вы ДОЛЖНЫ посылать величину не как Value, а как .Text. Если необходимо, приведите это к типу str (или PChar??), но в данном случае я получил эту величину из компонента DBEdit с флагом "только для чтения", т.к. я использовал его для представления приращиваемого (AutoIncrement) поля.

[000227]


Delphi 1

Передача переменных отчета в ReportSmith II

Тема: Передача переменных в отчет ReportSmith

Следующий код демонстрирует технологию передачи переменных в отчет ReportSmith.

Примечание: данный совет подразумевает ваше знание темы создания отчета со включенными переменными отчета. Для получения дополнительной информации обратитесь к электронной справке по ReportSmith к главе 'Creating Reports' (создание отчетов), поставляемой вместе с Delphi.

В нашем случае мы присвоим значение ('CA') строковой переменной отчета с именем 'state'.

Код ReportSmith:

Данная информация размещается в ReportSmith в диалоге ReportVariables (переменные отчета). Данный диалог можно вызвать, выбирая в меню Rreportsmith Tools | Report Query и нажимая на кнопку Report Variables.

  Name: state
  Type: string
  Title: state var
  Prompt: Введите ваше любимое состояние.
  Entry: type-in
  Report Variables: state ; Имейте в виду,
  что данная переменная и хранимое в ней
  значение при передаче в ReportSmith
  чувствительны к регистру.
Код Delphi:

Данный код подразумевает, что вы разместили на форме компонент TReport, назвали его 'Report1' и установили его свойство ReportName в соответствии с именем отчета, передаваемого в переменной, приведенной выше.

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

procedure TForm1.Button1Click(Sender: TObject);
var s: string;
begin
s:='CA';
Report1.InitialValues.Add('@state=<'+s+'>');
Report1.run;
end;

[000941]


Delphi 1

ReportSmith и пароль

Я использую Delphi и ReportSmith при работе с базой данных Oracle, требующей пароль для доступа. Всякий раз, когда я запускаю свой отчет ReportSmith, возникает диалоговое окно, требующее снова ввести пароль.

Все, что вам нужно сделать - это использовать метод connect объекта TReport. Он требует 5 параметров:

    Type
    Server
    UserId
    Password
    Database
Что делаю я: я определяю параметры соединения непосредственно в ReportSmith. Этим способом я помещаю все 5 параметров, включая пароль, в файл RPTSMITH.CON, находящийся в директории Windows. Приблизительно так:
  Type=67
  Server=PERSSQL
  UserId=SYSDBA
  Password=
  Database=C:\WORK\DELPHI\DATA\PERSDATA\PERS-SQL.GDB
При старте приложения пользователь вводит свое имя и пароль. Из файла RPTSMITH.CON я читаю параметры 1, 2 и 5. Затем я вызываю метод connect с 5-ю параметрами. С каждым вызовом метода connect, я могу изменять свойство ReportName. Похоже, Reportsmith в этом случае работает как надо.

Andy Scanlon. [000735]


Delphi 1

Пропуск заставки ReportSmith

Тема: Логотип Report Smith

В RS_RUN.INI должно быть:

 [RS_Runtime]
 ShowAboutBox=0
В RPTSMITH.INI должно быть:
 [ReportSmith]
 ShowAboutBox=0
- Ralph Friedman [000847]


Пример DDE & WordPerfect

Вот небольшой пример, скопированный из моего проекта:

procedure TForm1.PrintSave(Doc : String);
var
ProdDoc, ArchDoc : String;
WPCommands : TStringList;
begin
ProdDoc := ProdDrive + Doc;
ArchDoc := ArchDrive + Doc;

WPCommands := TStringList.Create;
with WPCommands do begin
Add('FileOpen(Filename:"'+ProdDoc+'")' );
Add('FileSave(Filename:"'+ProdDoc+'";ExportType:3;Overwrite:1)');

Add('PrintCopies(NumberOfCopies:2)');
Add('PrintCopiesBy(CopiesBy:1) ');
Add('PrintFullDoc() ');
Add('DocCompare(FileName:"'+ArchDoc+'";CompFlags:1) ');
Add('FileSave(Filename:"'+EMailDoc+'";ExportType:3;Overwrite:1');

Add('Close(Save:0) ');
end;

if  PDDE.ExecuteMacroLines(WPCommands, True) then begin
log('WPCommand Worked!')
{  Теперь необходимо подождать WP, чтобы завершить команду... }
end
else log('Ошибка WPCommand!');

WPCommands.Free;
end;

Примечание: Вы не можете использовать 'True!' или 'False!', как это делается в макросах WP. Вы должны использовать числовые значения. Как узнать числовой эквивалент команды: если в WP использовать построитель макросов, то можно передавать перечислимые типы в диалоговое окно и узнавать их числовой эквивалент.

Все это проверено, DDE работает в связке WP/Delphi, первая команда возвращает сообщение 'Ok, я получил это', и запускает макрос. При попытке послать второй запрос DDE, он ожидает завершение обработки первого, выводит сообщение типа 'Необходимо подождать....', после чего немедленно передает управление. Мне хотелось бы дождаться команды завершения прежде, чем я возвращусь из своей процедуры.

John Studt [000701]


Заголовок TGA-файла

OK, берем книжку 'Graphics File Formats, 2nd Edition' (форматы графических файлов) авторов David C. Kay & John R. Levine, и читаем формат заголовка файла для хранения изображения формата Targa.

Описание заголовка файла для изображения формата Targa
Смещение | Длина (в байтах) | Описание
0 | 1 | Длина ID-поля (ID Field Length)
1 | 1 | Тип цветовой карты (Color-map Type)
2 | 1 | Тип изображения (Image Type)
Информация о специфике цветовой карты (Color-map-specific Info)
3 | 2 | Первое включение цветовой карты (First Color-map Entry)
5 | 2 | Длина цветовой карты (Color-map Length)
7 | 1 | Размер цветовой карты (Color-map Entry Size)
Информация о специфике изображения (Image-specific Info)
8 | 2 | Горизонтальная координата начала изображения (Image X Origin)
10 | 2 | Вертикальная координата начала изображения (Image Y Origin)
12 | 2 | Ширина изображения (Image Width)
14 | 2 | Высота изображения (Image Height)
16 | 1 | Бит на пиксел (Bits-Per-Pixel)
17 | 1 | Биты дескриптора изображения (Image-Descriptor Bits)

Для изображений с разрешением True-color значение типа цветовой карты должно равняться нулю, в остальных случаях единице. В случае, когда цветовая карта присутствует, ее размер должен равняться значению 15, 16, 24 или 32. Для значений 15 и 16 каждая цветовая карта при загрузке использует 2 байта в формате:

Верхний байт    Нижний байт
A RRRRR GG      GGG BBBBB

где бит 'A' устанавливается в 0 для 15-битных цветовых величин. 24-битный размер карты хранится как три байта в следующем порядке: (B)lue (синий), (G)reen (зеленый), и (R)ed (красный). 32-битный размер цветовой карты использует четыре байта, ее порядок такой: (B)lue (синий), (G)reen (зеленый), (R)ed (красный) и значение атрибута - (A)ttribute.

Наконец, код, хранящий тип изображения (Image Type) должен содержать одно из следующих значений:

Код             Описание
----            -----------
0               Изображение отсутствует
1               Цветовая карта, без компрессии
2               True-color, без компрессии
3               Черно-белое, без компрессии
9               Цветовая карта, RLE-компрессия
10              True-color, RLE-компрессия
11              Черно-белое, RLE-компрессия
Горизонтальная и вертикальная координата начала изображения (Image X & Y Origins) и размеры изображения (Image Width & Height) разъяснений не требуют. Бит на пиксел (Bits-Per-Pixel) обозначает количество битов, содержащихся в точке изображения и может быть равен значению 8, 16, 24, и 32.

Биыт дескриптора изображения (The Image Descriptor bytes) содержит несколько полей битов, которые содержат следующую информацию:

Биты            Описание
----            -----------
0-3             Биты атрибутов (описаны ниже)
4               Ориентация Слева-на-Право 0=Л/П 1=П/Л
5               Ориентация Вехр/Низ 0=Н/В 1=В/Н
6-7             Чередование линий 00H=Нет, 40H=2 линии, 80H=4 линии
Биты атрибутов используются для определения атрибутов цветов в цветовой карте или true-color пикселах. 0 - alpha-данные (alpha-канал) отсутствуют, 1 - игнорирование или неопределено, 2 - не определено, но должно быть сохранено, 3 - наличие alpha-данных и 4 - информация о пикселе уже была умножена на alpha-величину.

Файлы версии Targa 2.0 также имеют файловый колонтитул, который может содержать дополнительное изображение или комментарии. Эти файлы всегда заканчиваются строкой-терминатором 'TRUEVISION-TARGA.'. Так, если ваше Targa-изображение заканчивается значением 'TRUEVISION-TARGA.' + 00H, то вы можете извлечь восемь байтов до строки, чтобы найти начало расширенной области и месторасположение каталога сборки данного файла. Обычно файловый колонтитул версии 2.0 имеет следующий формат:

Формат файлового колонтитула Targa версии 2.0
Байт | Длина | Описание
0 | 4 | 32-битное смещение расширенной области
4 | 4 | 32-битное смещение каталога сборки
8 | 17 | TRUEVISION-TARGA.
25 | 1 | Двоичный ноль ($0)

Я не собираюсь давать полные описания каталога сборки и области расширения. Вместо этого я приведу описание "почтовой марки", которая может содержаться в формате Targa V2.0. Данная "марка"-иконка должна иметь размеры 64 X 64 пикселей, представляет собой уменьшенный образ изображения, может включаться в файл по желанию компоновщика и не является обязательной.

Область расширения
Смещение | Длина | Описание
0 | 2 | Размер области расширения (должна быть 495)
2 | 41 | Имя автора
43 | 81 | Авторские комментарии
124 | 81 | Авторские комментарии
205 | 81 | Авторские комментарии
286 | 81 | Авторские комментарии
367 | 2 | Месяц создания
369 | 2 | День создания
371 | 2 | Год создания
... | ... | ...
482 | 4 | Смещение в файле таблицы цветовой коррекции
486 | 4 | Смещение в файле изображения "почтовой марки"
490 | 4 | Смещение в файле таблицы чередования линий
494 | 1 | Байты атрибутов

Данная "почтовая марка", при наличии, может быть использована вами непосредственно. Она хранится в виде несжатого изоюражения в том же цветовом формате (цветовой карте или True-color), как и исходное изображение. [000108]


*** Рисование КРИВЫХ в Delphi? ***

Решение 1

Автор: dmitrys@phyast.la.asu.edu (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().

Решение 2

В: У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте. Пожалуйста используйте для ответа мой адрес электронной почты.

Я решил ответить на этот крик души - причина?: 1. Не первый раз вижу подобный вопрос, 2. Задача настолько избита, что я без труда нашел ответ в своем архиве. (BTW: У меня есть более старые решения, чем это ;-P)

Тем не менее эта технология жива до сих пор и приносит свои плоды:

(********************************************************************)
(*                         GRAPHIX TOOLBOX 4.0                      *)
(*       Copyright (c) 1985, 87 by  Borland International, Inc.     *)
(********************************************************************)
 unit GShell;

interface

{------------------------------ вырезано --------------------------}

procedure Bezier(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer);

implementation

{------------------------------ вырезано --------------------------}

procedure Bezier{(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer)};
const
MaxControlPoints = 25;
type
CombiArray = array[0..MaxControlPoints] of Float;
var
N : integer;
ContrPoint, IntPoint : integer;
T, SumX, SumY, Prod, DeltaT, Quot : Float;
Combi : CombiArray;

begin
MaxContrPoints := MaxContrPoints - 1;
DeltaT := 1.0 / (MaxIntPoints - 1);
Combi[0] := 1;
Combi[MaxContrPoints] := 1;
for N := 0 to MaxContrPoints - 2 do
Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1);
for IntPoint := 1 to MaxIntPoints do
begin
T := (IntPoint - 1) * DeltaT;
if T <= 0.5 then
begin
Prod := 1.0 - T;
Quot := Prod;
for N := 1 to MaxContrPoints - 1 do
Prod := Prod * Quot;
Quot := T / Quot;
SumX := A[MaxContrPoints + 1, 1];
SumY := A[MaxContrPoints + 1, 2];
for N := MaxContrPoints downto 1 do
begin
SumX := Combi[N - 1] * A[N, 1] + Quot * SumX;
SumY := Combi[N - 1] * A[N, 2] + Quot * SumY;
end;
end
else
begin
Prod := T;
Quot := Prod;
for N := 1 to MaxContrPoints - 1 do
Prod := Prod * Quot;
Quot := (1 - T) / Quot;
SumX := A[1, 1];
SumY := A[1, 2];
for N := 1 to MaxContrPoints do
begin
SumX := Combi[N] * A[N + 1, 1] + Quot * SumX;
SumY := Combi[N] * A[N + 1, 2] + Quot * SumY;
end;
end;
B[IntPoint, 1] := SumX * Prod;
B[IntPoint, 2] := SumY * Prod;
end;
end; { Bezier }

end. { GShell }

[000110]


Несколько программ для работы с точечной графикой (2D и 3D)

unit Functs;

interface

uses
WinTypes, Classes, Graphics, SysUtils;

type
TPoint2D = record
X, Y: Real;
end;
TPoint3D = record
X, Y, Z: Real;
end;

function Point2D(X, Y: Real): TPoint2D;
function RoundPoint(P: TPoint2D): TPoint;
function FloatPoint(P: TPoint): TPoint2D;
function Point3D(X, Y, Z: Real): TPoint3D;
function Angle2D(P: TPoint2D): Real;
function Dist2D(P: TPoint2D): Real;
function Dist3D(P: TPoint3D): Real;
function RelAngle2D(PA, PB: TPoint2D): Real;
function RelDist2D(PA, PB: TPoint2D): Real;
function RelDist3D(PA, PB: TPoint3D): Real;
procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
function Dist2P(P, P1, P2: TPoint2D): Real;
function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
function SubPoints(P1, P2: TPoint2D): TPoint2D;

function Invert(Col: TColor): TColor;
function Dark(Col: TColor; Percentage: Byte): TColor;
function Light(Col: TColor; Percentage: Byte): TColor;
function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
function MMix(Cols: array of TColor): TColor;
function Log(Base, Value: Real): Real;
function Modulator(Val, Max: Real): Real;
function M(I, J: Integer): Integer;
function Tan(Angle2D: Real): Real;
procedure Limit(var Value: Integer; Min, Max: Integer);
function Exp2(Exponent: Byte): Word;
function GetSysDir: String;
function GetWinDir: String;

implementation

function Point2D(X, Y: Real): TPoint2D;
begin
Point2D.X := X;
Point2D.Y := Y;
end;

function RoundPoint(P: TPoint2D): TPoint;
begin
RoundPoint.X := Round(P.X);
RoundPoint.Y := Round(P.Y);
end;

function FloatPoint(P: TPoint): TPoint2D;
begin
FloatPoint.X := P.X;
FloatPoint.Y := P.Y;
end;

function Point3D(X, Y, Z: Real): TPoint3D;
begin
Point3D.X := X;
Point3D.Y := Y;
Point3D.Z := Z;
end;

function Angle2D(P: TPoint2D): Real;
begin
if P.X = 0 then
begin
if P.Y > 0 then Result := Pi / 2;
if P.Y = 0 then Result := 0;
if P.Y < 0 then Result := Pi / -2;
end
else
Result := Arctan(P.Y / P.X);

if P.X < 0 then
begin
if P.Y < 0 then Result := Result + Pi;
if P.Y >= 0 then Result := Result - Pi;
end;

If Result < 0 then Result := Result + 2 * Pi;
end;

function Dist2D(P: TPoint2D): Real;
begin
Result := Sqrt(P.X * P.X + P.Y * P.Y);
end;

function Dist3D(P: TPoint3D): Real;
begin
Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);
end;

function RelAngle2D(PA, PB: TPoint2D): Real;
begin
RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;

function RelDist2D(PA, PB: TPoint2D): Real;
begin
Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;

function RelDist3D(PA, PB: TPoint3D): Real;
begin
RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
end;

procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);
Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);
P := Temp;
end;

procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp := SubPoints(P, PCentr);
Rotate2D(Temp, Angle2D);
P := AddPoints(Temp, PCentr);
end;

procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X + (Cos(Angle2D) * Distance);
Temp.Y := P.Y + (Sin(Angle2D) * Distance);
P := Temp;
end;

function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
begin
Between.X := PA.X * Preference + PB.X * (1 - Preference);
Between.Y := PA.Y * Preference + PB.Y * (1 - Preference);
end;

function DistLine(A, B, C: Real; P: TPoint2D): Real;
begin
Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
end;

function Dist2P(P, P1, P2: TPoint2D): Real;
begin
Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
end;

function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
begin
Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
end;

function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
begin
Result := False;
if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P2, P) <= 0 then
if Abs(Dist2P(P, P1, P2)) < D then Result := True;
end;

function AddPoints(P1, P2: TPoint2D): TPoint2D;
begin
AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
end;

function SubPoints(P1, P2: TPoint2D): TPoint2D;
begin
SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
end;

function Invert(Col: TColor): TColor;
begin
Invert := not Col;
end;

function Dark(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col);
R := Round(R * Percentage / 100);
G := Round(G * Percentage / 100);
B := Round(B * Percentage / 100);
Dark := RGB(R, G, B);
end;

function Light(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col);
R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255);
G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255);
B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255);
Light := RGB(R, G, B);
end;

function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 - Percentage) / 100));
G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 - Percentage) / 100));
B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 - Percentage) / 100));
Mix := RGB(R, G, B);
end;

function MMix(Cols: array of TColor): TColor;
var
I, R, G, B, Length: Integer;
begin
Length := High(Cols) - Low(Cols) + 1;
R := 0; G := 0; B := 0;
for I := Low(Cols) to High(Cols) do
begin
R := R + GetRValue(Cols[I]);
G := G + GetGValue(Cols[I]);
B := B + GetBValue(Cols[I]);
end;
R := R div Length;
G := G div Length;
B := B div Length;
MMix := RGB(R, G, B);
end;

function Log(Base, Value: Real): Real;
begin
Log := Ln(Value) / Ln(Base);
end;

function Power(Base, Exponent: Real): Real;
begin
Power := Ln(Base) * Exp(Exponent);
end;

function Modulator(Val, Max: Real): Real;
begin
Modulator := (Val / Max - Round(Val / Max)) * Max;
end;

function M(I, J: Integer): Integer;
begin
M := ((I mod J) + J) mod J;
end;

function Tan(Angle2D: Real): Real;
begin
Tan := Sin(Angle2D) / Cos(Angle2D);
end;

procedure Limit(var Value: Integer; Min, Max: Integer);
begin
if Value < Min then Value := Min;
if Value > Max then Value := Max;
end;

function Exp2(Exponent: Byte): Word;
var
Temp, I: Word;
begin
Temp := 1;
for I := 1 to Exponent do
Temp := Temp * 2;
Result := Temp;
end;

function GetSysDir: String;
var
Temp: array[0..255] of Char;
begin
GetSystemDirectory(Temp, 256);
Result := StrPas(Temp);
end;

function GetWinDir: String;
var
Temp: array[0..255] of Char;
begin
GetWindowsDirectory(Temp, 256);
Result := StrPas(Temp);
end;

end.

[000120]


Delphi 2

Поворот изображения на 90 градусов

Новый модуль имеет три программы: RotateBitmap90DegreesClockwise, RotateBitmap90DegreesCounterClockwise, и RotateBitmap180Degrees. Все три используют TBitmap как переменную и вращают его согласно своему названию.

Два предостережения: Это все еще не совсем работает в Delphi3. Появляется какой-то шум на краях изображения. Мне кажется это из-за какой-то ошибки в методе LoadFromStream объекта TBitmap, но это может быть и моей ошибкой. Тем не менее есть другие решения, связанные с использованием свойства ScanLine, так что эта проблема решается. Во-вторых, этот алгоритм не работает с сжатыми RLE-алгоритмом изображениями. 4- и 8-битные (по разрешению) изображения могут быть декодированы и хранится в памяти: на случай, если они потребуются, у нас есть их дескриптор. К тому же, если изображение сжато, можно просто получить дескриптор канвы с нормальным изображением:

ABitmap.Canvas.Handle;

Этим мы также назначаем контекст устройства (то есть экрана), и, вероятно, сможем обрабатывать изображения вплоть до 24-битного формата. Что-то вроде компромисного решения.

Во всяком случае это работает у меня в Delphi 1 и 2 с черно-белыми, 4-, 8-, 16-, 24-, и 32-битными изображениями (но не с 4- и 8-битными изображениями, сжатыми RLE-алгоритмом, как я уже говорил выше).

unit bmpRot;

interface

uses
(*$IFDEF Win32*) Windows, (*$ELSE*) WinTypes, WinProcs, (*$ENDIF*)
Classes, Graphics;

procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap);
procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap);
procedure RotateBitmap180Degrees(var ABitmap: TBitmap);

implementation

uses
Dialogs;

(*$IFNDEF Win32*)

type
DWORD = LongInt;
TSelOfs = record
L, H: Word;
end;

procedure Win16Dec(var P: Pointer; const N: LongInt); forward;

procedure Win16Inc(var P: Pointer; const N: LongInt);
begin
if N < 0 then
Win16Dec(P, -N)
else if N > 0 then begin
Inc( TSelOfs(P).H, TSelOfs(N).H * SelectorInc );
Inc( TSelOfs(P).L, TSelOfs(N).L );
if TSelOfs(P).L < TSelOfs(N).L then Inc( TSelOfs(P).H, SelectorInc );
end;
end;

procedure Win16Dec(var P: Pointer; const N: LongInt);
begin
if N < 0 then
Win16Inc(P, -N)
else if N > 0 then begin
if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc );
Dec( TSelOfs(P).L, TSelOfs(N).L );
Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc );
end;
end;

(*
procedure HugeShift; far; external 'KERNEL' index 113;
procedure Win16Dec(var P: Pointer; const N: LongInt); forward;

procedure Win16Inc(var HugePtr: Pointer; Amount: LongInt);
procedure HugeInc; assembler;
asm
mov ax, Amount.Word[0]        { Сохраняем сумму в DX:AX. }
mov dx, Amount.Word[2]
les bx, HugePtr               { Получаем ссылку на HugePtr. }
add ax, es:[bx]               { Добавление коррекции. }
adc dx, 0                     { Распространяем перенос на наибольшую величину суммы. }
mov cx, Offset HugeShift
shl dx,                       { Перемещаем наибольшую величину суммы для сегмента. }
add es:[bx+2], dx             { Увеличиваем сегмент HugePtr. }
mov es:[bx], ax
end;

begin
if Amount > 0 then HugeInc else if Amount < 0 then Win16Dec(HugePtr, -Amount);
end;

procedure Win16Dec(var P: Pointer; const N: LongInt);
begin
if N < 0 then
Win16Inc(P, -N)
else if N > 0 then begin
if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc );
Dec( TSelOfs(P).L, TSelOfs(N).L );
Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc );
end;
end;
*)

(*$ENDIF*)

procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap);
const
BitsPerByte = 8;

var
{
Целая куча переменных. Некоторые имеют дело только с одно- и четырех-битовыми
изображениями, другие только с восемью- и 24-битовыми, а некоторые с обоими.
Любая переменная, оканчивающаяся символом 'R', имеет отношение к вращению изображения,
например если MemoryStream содержит исходное изображение, то MemoryStreamR - повернутое.
}
PbmpInfoR: PBitmapInfoHeader;
bmpBuffer, bmpBufferR: PByte;
MemoryStream, MemoryStreamR: TMemoryStream;
PbmpBuffer, PbmpBufferR: PByte;
BytesPerPixel, PixelsPerByte: LongInt;
BytesPerScanLine, BytesPerScanLineR: LongInt;
PaddingBytes: LongInt;
BitmapOffset: LongInt;
BitCount: LongInt;
WholeBytes, ExtraPixels: LongInt;
SignificantBytes, SignificantBytesR: LongInt;
ColumnBytes: LongInt;
AtLeastEightBitColor: Boolean;
T: LongInt;

procedure NonIntegralByteRotate; (* вложение *)
{
Эта программа осуществляет поворот изображений с разрешением меньшим, чем 8 бит на пиксел,
а имеено: черно-белые (1-бит) и 16-цветные (4-бит) изображения. Имейте в виду, что
такие вещи, как 2-битные изображения также могли бы вращаться, но Microsoft не включил
данный формат в свои спецификации и не поддерживает его.
}
var
X, Y: LongInt;
I: LongInt;
MaskBits, CurrentBits: Byte;
FirstMask, LastMask: Byte;
PFirstScanLine: PByte;
FirstIndex, CurrentBitIndex: LongInt;
ShiftRightAmount, ShiftRightStart: LongInt;

begin
(*$IFDEF Win32*)
Inc(PbmpBuffer, BytesPerScanLine * (PbmpInfoR^.biHeight - 1) );
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), BytesPerScanLine * (PbmpInfoR^.biHeight - 1) );
(*$ENDIF*)

{ PFirstScanLine движется вдоль первой линии чередования bmpBufferR. }
PFirstScanLine := bmpBufferR;

{ Устанавливаем индексирование. }
FirstIndex := BitsPerByte - BitCount;

{
Устанавливаем битовые маски:

Для черно-белого изображения,
LastMask  := 00000001    и
FirstMask := 10000000

Для 4-битного изображения,
LastMask  := 00001111    и
FirstMask := 11110000

Зададим значения CurrentBits и MaskBits, так как мы будем перемещаться по ним:
Для монохромных изображений:
10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001
Для 4-битных изображений:
11110000, 00001111

CurrentBitIndex определяет расстояние от крайнего правого бита
до позиции CurrentBits. Например, если мы находимся в одиннадцатой
колонке черно-белого изображения, CurrentBits равен
11 mod 8 := 3, или 3-й самый левый бит. Таким образом, крайне правый
бит должен переместиться на четыре позиции, чтобы попасть на позицию
CurrentBits. CurrentBitIndex как раз и хранит такое значение.
}
LastMask := 1 shl BitCount - 1;
FirstMask := LastMask shl FirstIndex;

CurrentBits := FirstMask;
CurrentBitIndex := FirstIndex;

ShiftRightStart := BitCount * (PixelsPerByte - 1);

{ Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. }
{ Помните что DIB'ы имеют происхождение противоположное DDB'сам. }

{ Счетчик Y указывает на текущую строчку исходного изображения. }
for Y := 1 to PbmpInfoR^.biHeight do begin
PbmpBufferR := PFirstScanLine;

{
Счетчик X указывает на текущую колонку пикселей исходного изображения.
Здесь мы имеем дело только с полностью заполненными байтами. Обработка
'частично заполненных' байтов происходит ниже.
}
for X := 1 to WholeBytes do begin
{
Выбираем биты, начиная с 10000000 для черно-белых и
заканчивая 11110000 для 4-битных изображений.
}
MaskBits := FirstMask;
{
ShiftRightAmount - сумма, необходимая для перемещения текущего байта
через весь путь (помните, я об этом говорил выше) в правую часть.
}
ShiftRightAmount := ShiftRightStart;
for I := 1 to PixelsPerByte do begin
{
Вот гарнир. Берем текущий байт вращаемого изображения и маскируем его
с not CurrentBits. Гасятся нулями только биты CurrentBits, сам байт перемещается
без изменений. Пример: Для черно-белого изображения, если бы мы
находились в 11-й колонке (см. пример выше), мы должны нулем погасить
3-й слева бит, то есть мы должны использовать PbmpBufferR^ и 11011111.

Теперь рассмотрим наш текущий исходный байт. Для черно-белых изображений
мы организуем цикл с шагом через бит, в общей сложности для восьми пикселей.
Для 4-битных изображений мы делаем цикл с обработкой четырех битов за проход для
двух пикселей. В любом случае мы делаем это через маскирование с
MaskBits ('PbmpBuffer^ и MaskBits'). Теперь нам нужно получить бит(ы)
из той колонки(ок), на которую отобразится CurrentBits. Мы это делаем с помощью
перемещения их в крайне правую часть байта ('shr ShiftRightAmount'),
затем сдвигая их налево с помощью вышеупомянутого
CurrentBitIndex ('shl CurrentBitIndex'). Дело в том, что хотя перемещение
вправо с параметром -n должно быть просто перемещением налево с параметром +n,
в Delphi это не работает. Итак, мы начинаем с первого байта, перемещая пиксели
в правую часть насколько это возможно незанятыми позициями.

Наконец, мы имеем наш исходный бит(ы), перемещенный на нужное место
с погашенными нулями битами. Последнее делаем непосредственно или с
помощью PbmpBufferR^ (гасим биты в CurrentBits, помните?).

Мда... "Просто". Ладно, поехали дальше.
}

PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or
( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex );

{ Сдвигаем MaskBits для следующей итерации. }
MaskBits := MaskBits shr BitCount;
(*$IFDEF Win32*)
{ Перемещаем наш указатель на буфер вращаемого изображения на одну линию чередования. }
Inc(PbmpBufferR, BytesPerScanLineR);
{ Нам не нужно перемещаться непосредственно вправо в течение некоторого времени. }
Dec(ShiftRightAmount, BitCount);
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR );
Win16Dec( Pointer(ShiftRightAmount), BitCount );
(*$ENDIF*)
end;
(*$IFDEF Win32*)
Inc(PbmpBuffer);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), 1 );
(*$ENDIF*)
end;

{ Если есть "частично заполненный" байт, самое время о нем позаботиться. }
if ExtraPixels <> 0 then begin
{ Делаем такие же манипуляции, как в цикле выше. }
MaskBits := FirstMask;
ShiftRightAmount := ShiftRightStart;
for I := 1 to ExtraPixels do begin
PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or
( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex );

MaskBits := MaskBits shr BitCount;
(*$IFDEF Win32*)
Inc(PbmpBufferR, BytesPerScanLineR);
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR );
(*$ENDIF*)
Dec(ShiftRightAmount, BitCount);
end;
(*$IFDEF Win32*)
Inc(PbmpBuffer);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), 1 );
(*$ENDIF*)
end;

(*$IFDEF Win32*)
{ Пропускаем заполнение. }
Inc(PbmpBuffer, PaddingBytes);
{
Сохраняем только что просмотренную линию чередования и переходим к следующей
для получения набора очередной строки.
}
Dec(PbmpBuffer, BytesPerScanLine shl 1);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), PaddingBytes );
Win16Dec( Pointer(PbmpBuffer), BytesPerScanLine shl 1 );
(*$ENDIF*)

if CurrentBits = LastMask then begin
{ Мы в конце этого байта. Начинаем с другой колонки. }
CurrentBits := FirstMask;
CurrentBitIndex := FirstIndex;
{ Идем вниз колонки вращаемого изображения , но одну колонку пропускаем. }
(*$IFDEF Win32*)
Inc(PFirstScanLine);
(*$ELSE*)
Win16Inc( Pointer(PFirstScanLine), 1 );
(*$ENDIF*)
end
else begin
{ Продолжаем заполнять этот байт. }
CurrentBits := CurrentBits shr BitCount;
Dec(CurrentBitIndex, BitCount);
end;
end;
end; { procedure NonIntegralByteRotate (* вложение *) }

procedure IntegralByteRotate; (* вложение *)
var
X, Y: LongInt;
(*$IFNDEF Win32*)
I: Integer;
(*$ENDIF*)

begin
{ Перемещаем PbmpBufferR в последнюю колонку первой линии чередования bmpBufferR. }
(*$IFDEF Win32*)
Inc(PbmpBufferR, SignificantBytesR - BytesPerPixel);
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR), SignificantBytesR - BytesPerPixel );
(*$ENDIF*)

{ Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. }
{ Помните что DIB'ы имеют происхождение противоположное DDB'сам. }
for Y := 1 to PbmpInfoR^.biHeight do begin
for X := 1 to PbmpInfoR^.biWidth do begin
{ Копируем пиксели. }
(*$IFDEF Win32*)
Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel);
Inc(PbmpBuffer, BytesPerPixel);
Inc(PbmpBufferR, BytesPerScanLineR);
(*$ELSE*)
for I := 1 to BytesPerPixel do begin
PbmpBufferR^ := PbmpBuffer^;
Win16Inc( Pointer(PbmpBuffer), 1 );
Win16Inc( Pointer(PbmpBufferR), 1 );
end;
Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR - BytesPerPixel);
(*$ENDIF*)
end;
(*$IFDEF Win32*)
{ Пропускаем заполнение. }
Inc(PbmpBuffer, PaddingBytes);
{ Идем вверх колонки вращаемого изображения , но одну колонку пропускаем. }
Dec(PbmpBufferR, ColumnBytes + BytesPerPixel);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), PaddingBytes);
Win16Dec( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel);
(*$ENDIF*)
end;
end;

{ Это тело процедуры RotateBitmap90DegreesCounterClockwise. }
begin
{ Никогда сами не вызывайте GetDIBSizes! Это испортит ваше изображение. }

MemoryStream := TMemoryStream.Create;

{
Для работы: Прежде всего установим размер. Это устранит перераспределение памяти
для MemoryStream. Вызов GetDIBSizes будет к месту, но, как отмечалось выше,
это может исказить ваше изображение. Вызов некоторых API функций вероятно
позаботился бы об этом, но это тема отдельного разговора.
}

{ Недокументированный метод. Все же программист иногда сродни шаману. }
ABitmap.SaveToStream(MemoryStream);

{ Изображение больше не нужно. Создадим новое когда понадобится. }
ABitmap.Free;

bmpBuffer := MemoryStream.Memory;
{ Получаем биты компенсации. Они могут содержать информацию о палитре. }
BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits;

{ Устанавливаем PbmpInfoR на указатель информационного заголовка исходного изображения. }
{ Эти заголовки могут немного раздражать, но они необходимы для работы. }
(*$IFDEF Win32*)
Inc( bmpBuffer, SizeOf(TBitmapFileHeader) );
(*$ELSE*)
Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) );
(*$ENDIF*)
PbmpInfoR := PBitmapInfoHeader(bmpBuffer);

{ Устанавливаем bmpBuffer и PbmpBuffer так, чтобы они указывали на биты оригинального изображения. }
bmpBuffer := MemoryStream.Memory;
(*$IFDEF Win32*)
Inc(bmpBuffer, BitmapOffset);
(*$ELSE*)
Win16Inc( Pointer(bmpBuffer), BitmapOffset );
(*$ENDIF*)
PbmpBuffer := bmpBuffer;

{
Имейте в виду, что нам не нужно беспокоиться о совместимости изображений версии 4 и 3,
поскольку области, которые мы используем, а именно -- biWidth, biHeight, и biBitCount --
располагаются на один и тех же местах в обоих структурах. Итак, одной проблемой меньше.
Изображения версии OS/2, между прочим, при этом гнусно рушатся. Обидно.
}
with PbmpInfoR^ do begin
{ ShowMessage('Компрессия := ' + IntToStr(biCompression)); }
BitCount := biBitCount;
{ ShowMessage('BitCount := ' + IntToStr(BitCount)); }

{ ScanLines - "выровненный" DWORD. }
BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD));
BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD));

AtLeastEightBitColor := BitCount >= BitsPerByte;
if AtLeastEightBitColor then begin
{ Нас не должен волновать бит-тильда. Классно. }
BytesPerPixel := biBitCount shr 3;
SignificantBytes := biWidth * BitCount shr 3;
SignificantBytesR := biHeight * BitCount shr 3;
{ Дополнительные байты необходимы для выравнивания DWORD. }
PaddingBytes := BytesPerScanLine - SignificantBytes;
ColumnBytes := BytesPerScanLineR * biWidth;
end
else begin
{ Одно- или четырех-битовое изображение. Уфф. }
PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount;
{ Все количество байтов полностью заполняется информацией о пикселе. }
WholeBytes := biWidth div PixelsPerByte;
{
Обрабатываем любые дополнительные биты, которые могут частично заполнять байт.
Например, черно-белое изображение, у которого 14 пикселей описываются каждый
соответственно своим байтом, плюс одним дополнительным, у которого на самом
деле используются 6 битов, остальное мусор.
}
ExtraPixels := biWidth mod PixelsPerByte;
{
Все дополнительные байты -- если имеются -- требуется DWORD-выровнять по
линии чередования.
}
PaddingBytes := BytesPerScanLine - WholeBytes;
{
Если есть дополнительные биты (то есть имеется 'дополнительный байт'),
то один из заполненных байтов уже был принят во внимание.
}
if ExtraPixels <> 0 then Dec(PaddingBytes);
end; { if AtLeastEightBitColor then }

{ TMemoryStream, обслуживающий вращаемые биты. }
MemoryStreamR := TMemoryStream.Create;
{
Устанавливаем размер вращаемого изображения. Может отличаться
от исходного из-за выравнивания DWORD.
}
MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth);
end; { with PbmpInfoR^ do }

{ Копируем заголовки исходного изображения. }
MemoryStream.Seek(0, soFromBeginning);
MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset);

{ Вот буфер, который мы будем "вращать". }
bmpBufferR := MemoryStreamR.Memory;
{ Пропускаем заголовки, yadda yadda yadda... }
(*$IFDEF Win32*)
Inc(bmpBufferR, BitmapOffset);
(*$ELSE*)
Win16Inc( Pointer(bmpBufferR), BitmapOffset );
(*$ENDIF*)
PbmpBufferR := bmpBufferR;

{ Едем дальше. }
if AtLeastEightBitColor then
IntegralByteRotate
else
NonIntegralByteRotate;

{ Удовлетворяемся исходными битами. }
MemoryStream.Free;

{ Теперь устанавливаем PbmpInfoR, чтобы он указывал на информационный заголовок вращаемого изображения. }
PbmpBufferR := MemoryStreamR.Memory;
(*$IFDEF Win32*)
Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) );
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) );
(*$ENDIF*)
PbmpInfoR := PBitmapInfoHeader(PbmpBufferR);

{ Меняем ширину с высотой в информационном заголовке вращаемого изображения. }
with PbmpInfoR^ do begin
T := biHeight;
biHeight := biWidth;
biWidth := T;
biSizeImage := 0;
end;

ABitmap := TBitmap.Create;

{ Вращение с самого начала. }
MemoryStreamR.Seek(0, soFromBeginning);
{ Загружаем это снова в ABitmap. }
ABitmap.LoadFromStream(MemoryStreamR);

MemoryStreamR.Free;
end;

procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap);
const
BitsPerByte = 8;

var
{
Целая куча переменных. Некоторые имеют дело только с одно- и четырех-битовыми
изображениями, другие только с восемью- и 24-битовыми, а некоторые с обоими.
Любая переменная, оканчивающаяся символом 'R', имеет отношение к вращению изображения,
например если MemoryStream содержит исходное изображение, то MemoryStreamR - повернутое.
}
PbmpInfoR: PBitmapInfoHeader;
bmpBuffer, bmpBufferR: PByte;
MemoryStream, MemoryStreamR: TMemoryStream;
PbmpBuffer, PbmpBufferR: PByte;
BytesPerPixel, PixelsPerByte: LongInt;
BytesPerScanLine, BytesPerScanLineR: LongInt;
PaddingBytes: LongInt;
BitmapOffset: LongInt;
BitCount: LongInt;
WholeBytes, ExtraPixels: LongInt;
SignificantBytes: LongInt;
ColumnBytes: LongInt;
AtLeastEightBitColor: Boolean;
T: LongInt;

procedure NonIntegralByteRotate; (* вложение *)
{
Эта программа осуществляет поворот изображений с разрешением меньшим, чем 8 бит на пиксел,
а имеено: черно-белые (1-бит) и 16-цветные (4-бит) изображения. Имейте в виду, что
такие вещи, как 2-битные изображения также могли бы вращаться, но Microsoft не включил
данный формат в свои спецификации и не поддерживает его.
}
 var
X, Y: LongInt;
I: LongInt;
MaskBits, CurrentBits: Byte;
FirstMask, LastMask: Byte;
PLastScanLine: PByte;
FirstIndex, CurrentBitIndex: LongInt;
ShiftRightAmount, ShiftRightStart: LongInt;

begin
{ Перемещаем PLastScanLine в первую колонку последней линии чередования bmpBufferR. }
PLastScanLine := bmpBufferR; (*$IFDEF Win32*) Inc(PLastScanLine, BytesPerScanLineR *
(PbmpInfoR^.biWidth - 1) ); (*$ELSE*) Win16Inc( Pointer(PLastScanLine),
BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ENDIF*)

{ Устанавливаем индексирование. }
FirstIndex := BitsPerByte - BitCount;

{
Устанавливаем битовые маски:

Для черно-белого изображения,
LastMask  := 00000001    и
FirstMask := 10000000

Для 4-битного изображения,
LastMask  := 00001111    и
FirstMask := 11110000

Зададим значения CurrentBits и MaskBits, так как мы будем перемещаться по ним:
Для черно-белых изображений:
10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001
Для 4-битных изображений:
11110000, 00001111

CurrentBitIndex определяет расстояние от крайнего правого бита
до позиции CurrentBits. Например, если мы находимся в одиннадцатой
колонке черно-белого изображения, CurrentBits равен
11 mod 8 := 3, или 3-й самый левый бит. Таким образом, крайне правый
бит должен переместиться на четыре позиции, чтобы попасть на позицию
CurrentBits. CurrentBitIndex как раз и хранит такое значение.
}
LastMask := 1 shl BitCount - 1;
FirstMask := LastMask shl FirstIndex;

CurrentBits := FirstMask;
CurrentBitIndex := FirstIndex;

ShiftRightStart := BitCount * (PixelsPerByte - 1);

{ Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. }
{ Помните что DIB'ы имеют происхождение противоположное DDB'сам. }

{ Счетчик Y указывает на текущую строчку исходного изображения. }
for Y := 1 to PbmpInfoR^.biHeight do begin
PbmpBufferR := PLastScanLine;

{
Счетчик X указывает на текущую колонку пикселей исходного изображения.
Здесь мы имеем дело только с полностью заполненными байтами. Обработка
'частично заполненных' байтов происходит ниже.
}
for X := 1 to WholeBytes do begin
{
Выбираем биты, начиная с 10000000 для черно-белых и
заканчивая 11110000 для 4-битных изображений.
}
MaskBits := FirstMask;
{
ShiftRightAmount - сумма, необходимая для перемещения текущего байта
через весь путь (помните, я об этом говорил выше) в правую часть.
}
ShiftRightAmount := ShiftRightStart;
for I := 1 to PixelsPerByte do begin
{
Вот гарнир. Берем текущий байт вращаемого изображения и маскируем его
с not CurrentBits. Гасятся нулями только биты CurrentBits, сам байт перемещается
без изменений. Пример: Для черно-белого изображения, если бы мы
находились в 11-й колонке (см. пример выше), мы должны нулем погасить
3-й слева бит, то есть мы должны использовать PbmpBufferR^ и 11011111.

Теперь рассмотрим наш текущий исходный байт. Для черно-белых изображений
мы организуем цикл с шагом через бит, в общей сложности для восьми пикселей.
Для 4-битных изображений мы делаем цикл с обработкой четырех битов за проход для
двух пикселей. В любом случае мы делаем это через маскирование с
MaskBits ('PbmpBuffer^ и MaskBits'). Теперь нам нужно получить бит(ы)
из той колонки(ок), на которую отобразится CurrentBits. Мы это делаем с помощью
перемещения их в крайне правую часть байта ('shr ShiftRightAmount'),
затем сдвигая их налево с помощью вышеупомянутого
CurrentBitIndex ('shl CurrentBitIndex'). Дело в том, что хотя перемещение
вправо с параметром -n должно быть просто перемещением налево с параметром +n,
в Delphi это не работает. Итак, мы начинаем с первого байта, перемещая пиксели
в правую часть насколько это возможно незанятыми позициями.

Наконец, мы имеем наш исходный бит(ы), перемещенный на нужное место
с погашенными нулями битами. Последнее делаем непосредственно или с
помощью PbmpBufferR^ (гасим биты в CurrentBits, помните?).

Мда... "Просто". Ладно, поехали дальше.
}
PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or
( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex );

{ Сдвигаем MaskBits для следующей итерации. }
MaskBits := MaskBits shr BitCount;
(*$IFDEF Win32*)
{ Перемещаем наш указатель на буфер вращаемого изображения на одну линию чередования. }
Dec(PbmpBufferR, BytesPerScanLineR);
(*$ELSE*)
Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR );
(*$ENDIF*)
{ Нам не нужно перемещаться непосредственно вправо в течение некоторого времени. }
Dec(ShiftRightAmount, BitCount);
end;
(*$IFDEF Win32*)
Inc(PbmpBuffer);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), 1 );
(*$ENDIF*)
end;

{ Если есть "частично заполненный" байт, самое время о нем позаботиться. }
if ExtraPixels <> 0 then begin
{ Делаем такие же манипуляции, как в цикле выше. }
MaskBits := FirstMask;
ShiftRightAmount := ShiftRightStart;
for I := 1 to ExtraPixels do begin
PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or
( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex );

MaskBits := MaskBits shr BitCount;
(*$IFDEF Win32*)
Dec(PbmpBufferR, BytesPerScanLineR);
(*$ELSE*)
Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR );
(*$ENDIF*)
Dec(ShiftRightAmount, BitCount);
end;
(*$IFDEF Win32*)
Inc(PbmpBuffer);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), 1 );
(*$ENDIF*)
end;

{ Пропускаем заполнение. }
(*$IFDEF Win32*)
Inc(PbmpBuffer, PaddingBytes);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), PaddingBytes );
(*$ENDIF*)

if CurrentBits = LastMask then begin
{ Мы в конце этого байта. Начинаем с другой колонки. }
CurrentBits := FirstMask;
CurrentBitIndex := FirstIndex;
{ Идем вниз колонки вращаемого изображения , но одну колонку пропускаем. }
(*$IFDEF Win32*)
Inc(PLastScanLine);
(*$ELSE*)
Win16Inc( Pointer(PLastScanLine), 1 );
(*$ENDIF*)
end
else begin
{ Продолжаем заполнять этот байт. }
CurrentBits := CurrentBits shr BitCount;
Dec(CurrentBitIndex, BitCount);
end;
end;
end; { procedure NonIntegralByteRotate (* вложение *) }

procedure IntegralByteRotate; (* вложение *)
var
X, Y: LongInt;
(*$IFNDEF Win32*)
I: Integer;
(*$ENDIF*)

begin
{ Перемещаем PbmpBufferR в первую колонку последней линии чередования bmpBufferR. }
(*$IFDEF Win32*)
Inc( PbmpBufferR, BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) );
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR) , BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) );
(*$ENDIF*)

{ Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. }
{ Remember that DIBs have their origins opposite from DDBs. }
for Y := 1 to PbmpInfoR^.biHeight do begin
for X := 1 to PbmpInfoR^.biWidth do begin
{ Копируем пиксели. }
(*$IFDEF Win32*)
Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel);
Inc(PbmpBuffer, BytesPerPixel);
Dec(PbmpBufferR, BytesPerScanLineR);
(*$ELSE*)
for I := 1 to BytesPerPixel do begin
PbmpBufferR^ := PbmpBuffer^;
Win16Inc( Pointer(PbmpBuffer), 1 );
Win16Inc( Pointer(PbmpBufferR), 1 );
end;
Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR + BytesPerPixel);
(*$ENDIF*)
end;
(*$IFDEF Win32*)
{ Пропускаем заполнение. }
Inc(PbmpBuffer, PaddingBytes);
{ Идем вверх колонки вращаемого изображения , но одну колонку пропускаем. }
Inc(PbmpBufferR, ColumnBytes + BytesPerPixel);
(*$ELSE*)
Win16Inc( Pointer(PbmpBuffer), PaddingBytes );
Win16Inc( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel );
(*$ENDIF*)
end;
end;

{ Это тело процедуры RotateBitmap90DegreesCounterClockwise. }
begin
{ Никогда сами не вызывайте GetDIBSizes! Это испортит ваше изображение. }

MemoryStream := TMemoryStream.Create;

{
Для работы: Прежде всего установим размер. Это устранит перераспределение памяти
для MemoryStream. Вызов GetDIBSizes будет к месту, но, как отмечалось выше,
это может исказить ваше изображение. Вызов некоторых API функций вероятно
позаботился бы об этом, но это тема отдельного разговора.
}

{ Недокументированный метод. Все же программист иногда сродни шаману. }
ABitmap.SaveToStream(MemoryStream);

{ Don't need you anymore. We'll make a new one when the time comes. }
ABitmap.Free;

bmpBuffer := MemoryStream.Memory;
{ Get the offset bits. This may or may not include palette information. }
BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits;

{ Устанавливаем PbmpInfoR на указатель информационного заголовка исходного изображения. }
{ Эти заголовки могут немного раздражать, но они необходимы для работы. }
(*$IFDEF Win32*)
Inc( bmpBuffer, SizeOf(TBitmapFileHeader) );
(*$ELSE*)
Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) );
(*$ENDIF*)
PbmpInfoR := PBitmapInfoHeader(bmpBuffer);

{ Устанавливаем bmpBuffer и PbmpBuffer так, чтобы они указывали на биты оригинального изображения. }
bmpBuffer := MemoryStream.Memory;
(*$IFDEF Win32*)
Inc(bmpBuffer, BitmapOffset);
(*$ELSE*)
Win16Inc( Pointer(bmpBuffer), BitmapOffset );
(*$ENDIF*)
PbmpBuffer := bmpBuffer;

{
Имейте в виду, что нам не нужно беспокоиться о совместимости изображений версии 4 и 3,
поскольку области, которые мы используем, а именно -- biWidth, biHeight, и biBitCount --
располагаются на один и тех же местах в обоих структурах. Итак, одной проблемой меньше.
Изображения версии OS/2, между прочим, при этом гнусно рушатся. Обидно.
}
with PbmpInfoR^ do begin
{ ShowMessage('Компрессия := ' + IntToStr(biCompression)); }
BitCount := biBitCount;
{ ShowMessage('BitCount := ' + IntToStr(BitCount)); }

{ ScanLines - "выровненный" DWORD. }
BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD));
BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD));

AtLeastEightBitColor := BitCount >= BitsPerByte;
if AtLeastEightBitColor then begin
{ Нас не должен волновать бит-тильда. Классно. }
BytesPerPixel := biBitCount shr 3;
SignificantBytes := biWidth * BitCount shr 3;
{ Дополнительные байты необходимы для выравнивания DWORD. }
PaddingBytes := BytesPerScanLine - SignificantBytes;
ColumnBytes := BytesPerScanLineR * biWidth;
end
else begin
{ Одно- или четырех-битовое изображение. Уфф. }
PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount;
{ Все количество байтов полностью заполняется информацией о пикселе. }
WholeBytes := biWidth div PixelsPerByte;
{
Обрабатываем любые дополнительные биты, которые могут частично заполнять байт.
Например, черно-белое изображение, у которого 14 пикселей описываются каждый
соответственно своим байтом, плюс одним дополнительным, у которого на самом
деле используются 6 битов, остальное мусор.
}
ExtraPixels := biWidth mod PixelsPerByte;
{
Все дополнительные байты -- если имеются -- требуется DWORD-выровнять по
линии чередования.
}
PaddingBytes := BytesPerScanLine - WholeBytes;
{
Если есть дополнительные биты (то есть имеется 'дополнительный байт'),
то один из заполненных байтов уже был принят во внимание.
}
if ExtraPixels <> 0 then Dec(PaddingBytes);
end; { if AtLeastEightBitColor then }

{ TMemoryStream, обслуживающий вращаемые биты. }
MemoryStreamR := TMemoryStream.Create;
{
Устанавливаем размер вращаемого изображения. Может отличаться
от исходного из-за выравнивания DWORD.
}
MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth);
end; { with PbmpInfoR^ do }

{ Копируем заголовки исходного изображения. }
MemoryStream.Seek(0, soFromBeginning);
MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset);

{ Вот буфер, который мы будем "вращать". }
bmpBufferR := MemoryStreamR.Memory;
{ Пропускаем заголовки, yadda yadda yadda... }
(*$IFDEF Win32*)
Inc(bmpBufferR, BitmapOffset);
(*$ELSE*)
Win16Inc( Pointer(bmpBufferR), BitmapOffset );
(*$ENDIF*)
PbmpBufferR := bmpBufferR;

{ Едем дальше. }
if AtLeastEightBitColor then
IntegralByteRotate
else
NonIntegralByteRotate;

{ Удовлетворяемся исходными битами. }
MemoryStream.Free;

{ Теперь устанавливаем PbmpInfoR, чтобы он указывал на информационный заголовок вращаемого изображения. }
PbmpBufferR := MemoryStreamR.Memory;
(*$IFDEF Win32*)
Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) );
(*$ELSE*)
Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) );
(*$ENDIF*)
PbmpInfoR := PBitmapInfoHeader(PbmpBufferR);

{ Меняем ширину с высотой в информационном заголовке вращаемого изображения. }
with PbmpInfoR^ do begin
T := biHeight;
biHeight := biWidth;
biWidth := T;
biSizeImage := 0;
end;

ABitmap := TBitmap.Create;

{ Вращение с самого начала. }
MemoryStreamR.Seek(0, soFromBeginning);
{ Загружаем это снова в ABitmap. }
ABitmap.LoadFromStream(MemoryStreamR);

MemoryStreamR.Free;
end;

procedure RotateBitmap180Degrees(var ABitmap: TBitmap);
var
RotatedBitmap: TBitmap;

begin
RotatedBitmap := TBitmap.Create;
with RotatedBitmap do begin
Width := ABitmap.Width;
Height := ABitmap.Height;
Canvas.StretchDraw( Rect(ABitmap.Width, ABitmap.Height, 0, 0), ABitmap );
end;
ABitmap.Free;
ABitmap := RotatedBitmap;
end;

end.

[000122]


Bitmap.Scanline для PixelFormat=pf1bit, pf8bit, pf24bit

(Техника программирования в Delphi 3)

Кто-то из Италии попросил меня пример использования pf1bit в изображениях (Bitmaps), я послал часто ответа из имеющихся заготовок, подумал, и добавил здесь другие детали для pf8bit и pf24bit.

Общее

Новое в Delphi 3 свойство scanline допускает быстрый доступ к отдельным пикселям, но необходимо указать с каким Bitmap.PixelFormat вы работаете, прежде чем сможете иметь доступ к пикселям.

Возможные PixelFormats включают:

  1. pfDevice
  2. pf1bit
  3. pf4bit
  4. pf8bit
  5. pf15bit
  6. pf16bit
  7. pf24bit
  8. pf32bit
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
...

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
...

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.
[000123]


Гауссово размывание (Gaussian Blur) в Delphi

Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает 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-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра. [000124]


Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки

Публикую полностью работу Den is Com. Основана на коде модуля gblur2 из предыдущего совета:

Данный метод позволяет создавать тень у текстовых меток 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.

[000814]


TurboPascal 7

Рисование фрактальных графов

Здравствуйте, Валентин!

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 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.

С наилучшими пожеланиями,
Михаил Марковский
mrkvsky@chem.kubsu.ru [000469]


Delphi 1

Растягивание иконки

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

Andrew

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

Пример кода:

procedure TForm1.StringGrid1Click(Sender: TObject);
begin
Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
Image1.Canvas.Draw(0, 0,
TIcon(StringGrid1.Objects
[StringGrid1.Col, StringGrid1.Row]));
Form2.Image1.Picture := Image1.Picture;
end;
{Примечание. Form2.Image1 имеет Stretch установленный в True и размер, бОльший размера иконки в 4 раза}

Надеюсь я помог вам.

Bill

Дополнение

Андрей Бреслав пишет:

предложенный способ не работает, ибо компонента TImage использует тот же метод StretchDraw, что и спрашивающий. Растянуть иконку можно так:

procedure TForm1.Button1Click(Sender: TObject);
var
Bmp: TBitMap;
begin
Bmp:= TBitMap.Create;
Bmp.Height:= GetSystemMetrics(SM_CYICON);
Bmp.Width:= GetSystemMetrics(SM_CXICON);
Bmp.Canvas.Draw(0,0, Image1.Picture.Icon);
Image1.Picture.Bitmap:= Bmp;
Bmp.Free;
end;

Есть более человечный способ, чем просто рисовать в Image: функция DrawIconEx Win32 API:

procedure TForm1.Button1Click(Sender: TObject);
begin
DrawIconEx(Canvas.Handle, 5, 5, LoadIcon(0, IDI_APPLICATION), 16, 32, 0,
0, DI_NORMAL);
end;

Кстати, думаю, людям будет полезно знать по подробнее о DrawIconEx: Рисует иконку или курсор в соответствии с заданными занчениями.

function DrawIconEx(hdc: HDC; xLeft, yTop: Integer; hIcon: HICON;
cxWidth, cyWidth: Integer; istepIfAniCur: UINT;
hbrFlickerFreeDraw: HBRUSH; diFlags: UINT): BOOL; stdcall;

  hdc - контекст устройства (TCanvas.Handle)
  xLeft, yTop - координаты левого верхнего угла
  hIcon - дескриптор объекта Windows - Icon
  cxWidth, cyWidth - размеры
  istepIfAniCur - (!) номер отображаемого кадра в анимированном курсоре
  hbrFlickerFreeDraw - кисть
  diFlags - сумма след. занчений:

DI_COMPAT - буду благодарен, если объясните
DI_DEFAULTSIZE - если cxWidth, cyWidth равны 0, рисует в default размере
DI_IMAGE - применяет одну часть кисти
DI_MASK - применяет другую часть кисти
DI_NORMAL = DI_IMAGE and DI_MASK - применяет обе части кисти
[000598]


Delphi 1

Код создания палитры

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;

[000654]


Delphi 1

Рисование без мерцания

...вот я и удивляюсь - почему я получаю мерцание, если я вызываю 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".

Mike Scott. [000684]


Delphi 1

Функция для работы с палитрами и 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;

[000689]


Delphi 1

Загрузка 256-цветного TBitmap

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');

-Steve Schafer [000709]


Delphi 1

Вращение изображения

Вот быстрый и примитивный способ вращения изображения. Должно работать. По крайней мере хоть какой-то выход из-положения, поскольку 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;

-Mike Williams [000715]


Delphi 1

Отображение ломанной линии

Как мне вывести ломанную линию на холсте, если я не знаю размер массива (количество точек) до момента запуска программы??? По-моему, это невозможно. Просветите меня!

Недавно я решал аналогичную проблему при кодировании ReportPrinter и не нашел хорошего решения для создания открытого массива параметров заданного размера. Решение, которое я, наконец, использовал, заключалось в хитрой комбинации функции polyline и polygon с ассемблерным кодом. Я публикую исходный код, поскольку думаю что он будет полезен, пока Borland не создаст стандартные и простые методы для работы с массивами заданного размера.

type
PPointArr = ^TPointArr;
TPointArr = array[0..16380] of TPoint;

var
I1: integer;
Elements: word;
PointArr: PPointArr;

begin
GetMem(PointArr,(Elements + 1) * SizeOf(TPoint));
try
For I1 := 0 to Elements do begin
PointArr^[I1].X := ReadNextXValue;
PointArr^[I1].Y := ReadNextYValue;
end; { for }

{ Вызов Polygon(PointArr^), но только с Elements+1-элеменами в открытом массиве }
asm
les di,PointArr { Помещаем указатель на PointArr }
push es
push di
push Elements { Помещаем High(PointArr^) }
les di,self { Помещаем указатель self }
push es
push di
les di,es:[di] { Вызов self.Polygon }
call Polygon
end; { asm }
finally
FreeMem(PointArr,(Elements + 1) * SizeOf(TPoint));
end; { try }
end;

Надеюсь это поможет.

Jim Gunkel
Nevrona Designs [000717]


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

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

unit Lines;  {от Bill Murto, CIS 73730,2505}

interface

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

type
TLineOrigin = (loTopLeft, loTopRight);
TLine = class(TGraphicControl)
private
{ Private declarations }
fOrigin: TLineOrigin;
fPen: TPen;
procedure SetOrigin(Value: TLineOrigin);
procedure SetPen(Value: TPen);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Origin: TLineOrigin read fOrigin write SetOrigin default
loTopLeft;
property Pen: TPen read fPen write SetPen;
property Height default 33;
property Width default 33;
procedure StyleChanged(Sender: TObject);
end;

procedure Register;

implementation

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

procedure TLine.SetOrigin(Value: TLineOrigin);
begin
if fOrigin <> Value then
begin
fOrigin := Value;
Invalidate;
end;
end;

procedure TLine.SetPen(Value: TPen);
begin
fPen.Assign(Value);
end;

procedure TLine.StyleChanged(Sender: TObject);
begin
Invalidate;
end;

constructor TLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 33;
Width := 33;
fPen := TPen.Create;
fPen.OnChange := StyleChanged;
if csOpaque in ControlStyle then
ControlStyle := ControlStyle - [csOpaque];
end;

procedure TLine.Paint;
begin
with Canvas do
begin
Pen := fPen;
if (Width <= Pen.Width) or (Height <= Pen.Width) then
begin
if Width <= Pen.Width then begin MoveTo(0, 0); LineTo(0, Height); end;
if Height <= Pen.Width then begin MoveTo(0, 0); LineTo(Width, 0); end;
end
else
case fOrigin of
loTopLeft: begin MoveTo(0, 0); LineTo(Width, Height); end;
loTopRight: begin MoveTo(Width, 0); LineTo(0, Height); end;
end;
end;
end;

destructor TLine.Destroy;
begin
fPen.Free;
inherited Destroy;
end;

end.

- William E Murto [000784]


Delphi 1

Создание DIB из BMP

Если файл хранится в формате 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 как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в ваш модуль.

- Mike Scott [000785]


Delphi 1

TImage - эффект плавного перехода

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

Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("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, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...)

- David C. Ullrich [000786]


Delphi 1

Создание и использование 256-цветной палитры

Вот пример того, как можно создать и использовать палитру для 256-цветных изображений. Вам, вероятно, необходимо использовать API функции SelectPalette и RealizePalette, в зависимости от того как вы хотите использовать ваше изображение.

procedure TfrmMain.MakePalette(forBitMap: TBitMap);
var
pNewPal : PLogPalette;
lSize   : LongInt;
nCntr   : Byte;
begin
lSize := SizeOf(TLogPalette) +
SizeOf(TPaletteEntry) * 256;
try
GetMem(pNewPal, lSize);
pNewPal^.palNumEntries := 256;
pNewPal^.palVersion := $300;
{$R-}{выключаем контроль допустимого диапазона}
{создаем данные палитры...}
for nCntr := 0 to 254 do
begin
pNewPal^.palPalEntry[nCntr].peRed   := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peGreen := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peBlue  := nCntr + 20;
pNewPal^.palPalEntry[nCntr].peFlags := pc_nocollapse;
end;
{$R+}{включаем контроль допустимого диапазона}
{удаляем старый hPal; предохраняемся от утечки памяти}
DeleteObject(hPal);
{создаем новую палитру на основе новых значений}
hPal := CreatePalette(pNewPal^);
{назначаем новую палитру}
forBitMap.Palette := hPal;
finally
FreeMem(pNewPal, lSize);
end;
end;

- Bob Teller [000826]


Delphi 1

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

Мне необходимо изменить цветовую палитру изображения с помощью 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 ;

- Mike Scott [000827]


Bitmap без формы

Как мне загрузить изображение (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 реализует для вас нужную палитру.

- Mike Scott [000910]


Delphi 1

Захват изображений

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

function  CopyPalette( Palette : HPalette ) : HPalette ;
var nEntries   : integer ;
LogPalSize : integer ;
LogPalette : PLogPalette ;
begin
Result := 0 ;
if Palette = 0 then exit ;
GetObject( Palette, sizeof( nEntries ), @nEntries ) ;
if nEntries < 1 then exit ;
LogPalSize := sizeof( TLogPalette ) + sizeof( TPaletteEntry ) * ( nEntries - 1 ) ;
GetMem( LogPalette, LogPalSize ) ;
with LogPalette^ do try
palVersion := $300 ;
palNumEntries := nEntries ;
GetPaletteEntries( Palette, 0, nEntries, palPalEntry[ 0 ] ) ;
Result := CreatePalette( LogPalette^ ) ;
finally
FreeMem( LogPalette, LogPalSize ) ;
end ;
end ;

procedure TForm1.Button1Click(Sender: TObject);
var Bitmap : TBitmap ;
begin
Bitmap := TBitmap.Create ;
try
Bitmap.Width := 50 ;
Bitmap.Height := 40 ;
Bitmap.Palette := CopyPalette( Image1.Picture.Bitmap.Palette ) ;
Bitmap.Canvas.CopyRect( Rect( 0, 0, 50, 40 ),
Image1.Picture.Bitmap.Canvas,
Bounds( 20, 10, 50, 40 ) ) ;
Bitmap.SaveToFile( 'c:\windows\temp\junk.bmp' ) ;
finally
Bitmap.Free ;
end ;
end;

- Mike Scott. [000912]


Delphi 2

Проблема с классом TBitmap

uses  Graphics, Classes, WinProcs, SysUtils;

type
TGxBitmap = class( TBitmap )    <<<<<<<<требуется тип класса

В Delphi 2.0 ссылка на WinProcs в действительности является ссылкой на модуль Windows. Модуль Windows практически является комбинацией модулей WinTypes и WinProcs. В нем определен тип с именем TBitmap и, поскольку WinProcs указан после Graphics, тип TBitmap в приведенном примере реально определяется в модуле Windows, а не Graphics.

Это работало в Delphi 1.0, поскольку вы должны были ссылаться на WinTypes для получения декларации TBitmap, но вы не делали этого.

Решение проблемы: в списке uses разместите Graphics после WinProcs.

- Pat Ritchey [000915]


Двоичный файл с набором изображений

Может кто-либо обеспечить меня хорошим примером как сохранить множество изображений в единственном бинарном файле?

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

Данный пример помещает вашу запись в объект. Хотя это и не было строго необходимым, я сконфигурировал алгоритм имеенно так, потому что рано или поздно вы это сделаете... В качестве средства для чтения и записи он использует потоки. Возможно вы уже использовали потоки, поэтому моя технология не будет для вас открытием. Одно из преимуществ использования потока в том, что для работы с графическими объектами -- bitmap, icon, metafile -- можно использовать методы SaveToStream и LoadFromStream.

У меня была проблема с использованием LoadFromStream, и она была похожей на вашу. При вызове Graphic.LoadFromStream, графика "оставляла" позицию потока с самом его конце, а не в конце записи. Другими словами, если графический объект первый раз записывал себя в поток, данные заканчивались в позиции 247. Но когда графический объект "читал себя", он не останавливался в позиции 247, а читал себя из всего потока. Поэтому мог быть прочитан только один объект.

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

Кое-то еще: я сделал объект, способным обрабатывать иконки, метафайлы, а также простые изображения. Не знаю, понадобиться ли вам это, и может быть я выбрал не самое элегантное решение...

unit Unit2;

interface
uses Graphics, Classes;

type
TAlbumRec = class
private
FGraphic: TGraphic;
FDescription: string;  { ...Просто пример поля }
FItemType: ShortInt;   { ...Просто пример поля }
procedure SetGraphic( AGraphic: TGraphic );
public
constructor Create;
destructor Destroy; override;
procedure LoadFromStream( Stream: TStream );
procedure SaveToStream( Stream: TStream );
property Graphic: TGraphic read FGraphic write SetGraphic;
property Description: string read FDescription write FDescription;
property ItemType: ShortInt read FItemType write FItemType;
end;

implementation

constructor TAlbumRec.Create;
begin
inherited Create;
end;

destructor TAlbumRec.Destroy;
begin
FGraphic.Free;
inherited Destroy;
end;

procedure TAlbumRec.LoadFromStream( Stream: TStream );
var
GraphicTypeCode: Char;
EndPosition: LongInt;
begin
{ Считываем в потоке позицию где заканчивается запись... }
Stream.Read( EndPosition, SizeOf( EndPosition ));

{ Считываем в Delphi 1.0 строку... }
Stream.Read( FDescription[ 0 ], SizeOf( Byte ));
Stream.Read( FDescription[ 1 ], Byte( FDescription[ 0 ]));

{ Читаем целое... }
Stream.Read( FItemType, SizeOf( FItemType ));

{ Считываем код, сообщающий тип графического объекта, который необходимо создать... }
Stream.Read( GraphicTypeCode, SizeOf( GraphicTypeCode ));

{ Освобождаем текущий графический объект и пересоздаем его.. }
FGraphic.Free;
FGraphic := nil;
case GraphicTypeCode of
'B': FGraphic := TBitmap.Create;
'I': FGraphic := TIcon.Create;
'M': FGraphic := TMetafile.Create;
end;

{ Загружаем из потока графику... }
if FGraphic <> nil then
FGraphic.LoadFromStream( Stream );

{ Ищем в потоке конечную позицию для данной записи. Почему мы это делаем? Я обнаружил это, когда графический объект читал себя из потока, и при этом "оставлял" позицию потока с самом его конце, а не в конце записи. Поэтому мог быть прочитан только один объект... }
Stream.Seek( EndPosition, 0 );
end;

procedure TAlbumRec.SaveToStream( Stream: TStream );
var
GraphicTypeCode: Char;
StartPosition,
EndPosition: LongInt;
begin
{ Запоминаем позицию потока для дальнейшей записи наших объектов... }
StartPosition := Stream.Position;

{ Здесь мы собираемся записать позицию где заканчиваются данные записи. Мы пока не знаем как это позиционируется, поэтому пока записываем ноль чтобы сохранить место... }
EndPosition := 0;
Stream.Write( EndPosition, SizeOf( EndPosition ));

{ Записываем строку Delphi 1.0... }
Stream.Write( FDescription[ 0 ], SizeOf( Byte ));
Stream.Write( FDescription[ 1 ], Byte( FDescription[ 0 ]));

{ Записываем целое... }
Stream.Write( FItemType, SizeOf( FItemType ));

{ Записываем код, сообщающий тип графического объекта, который мы собираемся писать... }
if ( FGraphic = nil ) or ( FGraphic.Empty ) then
GraphicTypeCode := 'Z'
else if FGraphic is TBitmap then
GraphicTypeCode := 'B'
else if FGraphic is TIcon then
GraphicTypeCode := 'I'
else if FGraphic is TMetaFile then
GraphicTypeCode := 'M';
Stream.Write( GraphicTypeCode, SizeOf( GraphicTypeCode ));

{ Записываем графику... }
if ( GraphicTypeCode <> 'Z'  ) then
FGraphic.SaveToStream( Stream );

{ Возвращаемся к месту откуда мы начинали и записываем конечную позицию, которую мы сохранили... }
EndPosition := Stream.Position;
Stream.Seek( StartPosition, 0 );
Stream.Write( EndPosition, SizeOf( EndPosition ));

{ Возвращаем конечную позицию, после этого поток готов для следующей записи... }
Stream.Seek( EndPosition, 0 );
end;

procedure TAlbumRec.SetGraphic( AGraphic: TGraphic );
begin
FGraphic.Free;
FGraphic := nil;
if AGraphic <> nil then
begin
FGraphic := TGraphic( AGraphic.ClassType.Create );
FGraphic.Assign( AGraphic );
end;
end;

end.

- Ed Jordan [000974]


Оглавление файлов помощи (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);

[000127]


Как мне привязать файлы помощи в Delphi 3?

Вот как это делаю я:

  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.

[000128]


Одной строкой

Показ диалога "Help Search" I

Application.HelpCommand(HELP_PARTIALKEY, 0);

Если данная команда не находит идентификатор #0 файла помощи (естественно, мы его и задаем), то она выводит диалог "Help Search". [000524]


Delphi 1

Показ диалога "Help Search" II

Следующий код демонстрирует способ вывода диалога WinHelp "Search" для электронной справки вашего приложения. Для этого следует послать системе электронной справки Windows (WinHelp) команду Help_PartialKey, что можно сделать с помощью метода объекта TApplication HelpCommand. Параметр для этой команды должен иметь тип PChar (можно привести к longint) и содержать строку, которую вам необходимо найти. Пример ниже использует для вызова диалога "Search" пустую строку, которую освобождает после его закрытия.

procedure TForm1.SearchHelp;
var
P: PChar;
begin
Application.HelpFile := 'c:\delphi\bin\delphi.hlp';
P := StrNew('');
Application.HelpCommand(Help_PartialKey, longint(P));
StrDispose(P);
end;

[000590]


Delphi 1

Использование файла помощи

Вот код для трех стандартных пунктов меню "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;

- Neil [000770]


Одной строкой

Закрытие файла помощи

При закрытии моего приложения окно помощи (если оно в это время открыто) автоматически не закрывается! Как мне сделать так, чтобы оно также закрывалось автоматически?

Попробуйте так:

Application.HelpCommand(HELP_QUIT, 0);

- Nick Hodges [000879]


Вывод окна CPU (дизассемблер)

Delphi 2.0

HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging\EnableCPU = "1"

Delphi 3.0

Используя редактор регистров найдите каталог

HKEY_CURRENT_USER\Software\Borland\Delphi\3.0\Debugging

и добавьте ключ ENABLECPU со значением "1".

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

[000129]


Delphi 2

Общий доступ к Хранилищу Объектов (ObjectRepository)

Процесс распространения форм и шаблонов проекта среди пользователей Delphi 2.0 немного более сложен, чем для Delphi 1.0, но основная идея та же. Самое большое различие заключается в том, что вы можете в Хранилище Объектов добавить форму, расположенную в другом каталоге, нежели само Хранилище. Из-за этой ситуации Delphi 2.0 не может предположить (как это делало Delphi 1.0), что все формы или файлы шаблонов будут в том же каталоге или его подкаталогах. (Это факт имеет важный смысл для форм и проектов, которые вы желаете распространять из Объектного Хранилища. Мы опишем этот смысл немного позже.)

Для создания общего доступа к Хранилищу Объектов вы должны сделать следующее:

  • Скопируйте файлы Object Repository, которые вы хотите распространять, в новый каталог
  • Скопируйте файл Delphi32.Dro из каталога \Delphi 2.0\Bin в новый каталог Хранилища Объектов
  • Найдите и замените в файле Delphi32.Dro все пути к старым каталогам Хранилища на путь к новому каталогу
  • В системных регистрах в секции Repository для Delphi 2.0 добавьте строку "BaseDir = значение", чтобы обозначить месторасположение Object Repository.
  • Перезапустите Delphi 2.0 у каждого пользователя
Как вы можете догадаться, проблема в этом процессе может возникнуть, если вы попытаетась распространить форму или проект, расположенный вне структуры каталогов по умолчанию \OBJREPOS. Если вы добавили проекты или формы в Объектное Хранилище, и каталог не существует в подкаталогах основного каталога Хранилища, вам понадобиться скопировать необходимые файлы для тех проектов и форм в новый каталог. Вдобавок, чтобы отразить новые пути, вы должны в файле Delphi32.Dro отредактировать пути, на которые ссылаются эти файлы.

Если вы не сделаете эти изменения, то у любого пользователя локальная копия Delphi 2, после загрузки файла Delphi32.Dro, начнет искать проекты и формы на локальном диске по несуществующему у данного пользователя пути. (Эти проекты и формы существуют только на компьютере, где их создали).

Пример

Теперь давайте определим коллективное Хранилище Объектов для Delphi 2.0. Для начала создайте новый каталог с именем C:\Object Repository 2 и скопируйте все файлы и каталоги из каталога \OBJREPOS в новый каталог. Кроме того, скопируйте файл Delphi32.Dro из каталога \Delphi 2.0\Bin также в новый каталог. Запустите текстовый редактор и откройте файл Delphi32.Dro. Найдите в этом файле все старые пути Хранилища Объектов, например такие:

C:\PROGRAM FILES\BORLAND\DELPHI 2.0\OBJREPOS

и замените на

C:\Object Repository 2

Этим вы найдете и измените пути с указанием на новое месторасположение файлов в Delphi32.Dro. Затем запустите редактор регистров (REGEDT32.EXE) и найдите ключ с именем

Software/Borland/Delphi/2.0/Repository

в секции HKEY_CURRENT_USER. Добавьте новую строковую величину (тип REG_SZ) с именем BaseDir и значением

C:\Object Repository 2

Закройте редактор регистров. После перезапуска Delphi 2.0 новый каталог будет содержать проект и шаблоны форм вашего Хранилища Объектов. [000133]


Как мне обнаружить, что программа запущена из-под IDE?

Решение 1

if csDesigning in ComponentState then
.....

Вы этого хотели, не правда ли...

Решение 2

Вот программка, работающая с Delphi 1. Если вы пользуетесь Delphi 2 и она работает и там, сообщите мне об этом удивительном факте.

function LaunchedFromDelphiIDE: Boolean;
{----------------------------------------------------------------}
{ Проверка того, запущено ли приложение из-под IDE или без него. }
{----------------------------------------------------------------}
begin
LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL} and
Bool(PWordArray(MemL[DSeg:36])^[8]);
end; {LaunchedFromDelphiIDE}

Решение 3 (также для Delphi 1)

Предположим, это вызывается из Delphi16-приложения, не DLL, данная функция возвращает True, если приложение работает под отладчиком и False в противном случае. Если вызов происходит из DLL, возвращается False. Комментарии излишни <g>.

- Brian Long

function DebuggerRunning: Boolean;
begin
Result := Bool(PrefixSeg) and Bool(PWordArray(MemL[DSeg:36])^[8]);
end;

[000134]


Регулярные выражения

Я не понимаю как работают REGULAR EXPRESSIONS (регулярные выражения) в Delphi-диалоге Replace dialog.

R e g u l a r  E x p r e s s i o n s
(Взято из файла помощи и переведено)
Регулярные выражения являются специальными символами, употребляемые при поиске или переводе строки, позволяющие создавать шаблоны поиска вместо точного побуквенного ввода искомого текста.

Регулярные выражения подобны шаблонам DOS, но являются более мощным инструментом.

Регулярные выражения
Выражение | Описание
? | Любой символ кроме конца строки
* | Ноль или более символов (за исключением символа конца строки)
\t | Символ табулятора
\n | Символ конца строки
\c | Позиция курсора после сравнения
\\ | Символ обратной косой черты
Символ | Описание
< или % | Начало строки
> или $ | Конец строки
@ | Ноль или более последних выражений
+ | Один или более последних выражений
 | Или последнее или следующее выражение
{} | Определение группы выражений
[ ] | Любой из символов в [ ]
[~ ] | Любой символ за исключением указанного в [~ ]
[a-z] | Любой символ между a и z включительно

В тексте замены допускаются \t, \n, \c, а также:

\<n>                   замещающий текст сравнивается с <n>-ной группой (0 <= n <= 9)

Примеры
Выражение | Результат
the | Поиск следующего включения "the"
{him} {her} | Поиск следующего включения "him" или "her"
<alone> или %alone$ | Поиск следующего включения "alone" в данной строке
stuff*between | Поиск следующего включения "stuff", сопровождающегося "between" на той же строке
th[eo]se | Поиск следующего включения "these" или "those"
[A-Z][a-z]@; | Поиск следующего слова, начинающегося с большой буквы и заканчивающегося точкой с запятой
[0-9]+ | Поиск одной или более последовательных цифр
[~ \t\n] | Поиск любого символа за исключением пробела, символа табулятора или новой строки

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

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

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

Поиск FString\[{*}\]

Замена Ord(FString[\0])

или

Поиск {FString\[*\]}

Замена Ord(\0)

[000259]


Дата компилляции

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

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

Для этого я создал файл "today.inc", где я храню необходимую информацию о времени компиляции приложения:

const
_day   : string[10] = 'Понедельник';
_date  : word = 12;
_month : word = 8;
_year  : word = 1996;

Затем просто вставьте строчку {$I c:\today.inc} в верхную части вашего кода.

Досадно, что компилятор не поддерживает директивы {$DATE}!

[000293]


Одной строкой

Потеря сохраненных файлов?

Будьте осторожными при работе с файлами за пределами каталога проекта. Очередной сохраняемый файл может оказаться совсем в другой директории. В случае, если проект использует файлы из разных каталогов, пользуйтесь командой "Save As". [000327]


Delphi 1

Проблемы с цветами в IDE

Да, действительно, некоторые части Delphi IDE имеют назначенные, а не системные цвета. [000336]


Delphi 1

Outline ошибка

Да, вы правы насчет Datasafe. Я получил ее, выполняя приложение, и когда это случилось, я смог включить интегрированную отладку в Delphi и выяснить в чем дело. Итак, сообщение для пользователей Datasafe - закомментарьте строчку DRIVERS=C:\....\DATASAFE.DLL в секции [BOOT] вашего System.ini, этим вы дезактивируете Datasafe. Естественно, если там имеются другие строчки с драйверами, они должны быть загружены. [000337]


Delphi 1

Шрифты редактора Delphi

Загрузите Панель Управления Windows и выберите "Шрифты". Убедитесь, что доступен по крайней мере один непропорциональный шрифт (например, Courier).

Редактор Delphi откажется работать, если не доступен хотя бы один непропорциональный шрифт. [000338]


Delphi 1

Размер библиотек и скорость загрузки IDE

DELPHI _очень_ увеличивает время своей загрузки после добавления VBX-ов и компонентов в палитру VCL.

  • DELPHI компилит ваши компоненты и оболочку VBX С ПОЛНЫМ ОТЛАДОЧНЫМ КОДОМ независимо от того, какие установки вы задали в OPTIONS | ENVIRONMENT LIBRARY
  • DELPHI НЕ ОПТИМИЗИРУЕТ complib.dcl по размеру и времени загрузки
Чтобы отделаться от этого суперумного отладочного кода, оптимизировать ваш DCL, получить самую быструю загрузку Delphi и уменьшить размер EXE-файла (ненамного), следуйте за этими шагами:

  1. перед тем, как компилировать коммерческую версию, первой строкой включите директивы компилятора {$D-,L-,Y-} во модулях всех ваших компонентов и исходного кода оболочек VBX
  2. запустите W8LOSS.EXE с вашим complib.dcl
[000360]


Delphi 1

Проблема блокировки ресурсов

Большое приложение может зависнуть при запуске из-под IDE.

В частности, если форма содержит много элементов управления.

В этом случае при запуске попробуйте закрыть такую форму. Это должно значительно освободить память и ресурсы GUI. [000437]


Delphi 1

Поиск процедуры/функции в IDE

Поместите курсор на имени функции и нажмите правую клавишу мыши. Выберите "Browse Symbol At Cursor". В появившимся окне просмотра выберите страницу ссылок (References). ОДНА из ссылок - определение функции/метода, если метод, то обычно она следует второй (первой идет строка декларации в определении объекта).

Это, конечно, не Shift+F2 в VB, но тоже работает... [000438]


Delphi 1

Перехват IDE

Да, есть возможность перехватывать работу Delphi IDE. Это подтверждается в модуле TOOLINTF.PAS, включенным в исходный код VCL. [000441]


Delphi 1

IDE: шрифт по умолчанию

Если вы хотите использовать шрифт, оличный от шрифта Delphi "по умолчанию", добавьте строку типа:

DefaultFont=Arial, 9

в секцию FormDesign файла Delphi.ini. [000456]


Delphi 1

Определение работы Delphi I

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

В секции implementation:

Const
InIDE: Boolean := False;

И в процедуре Register:

InIDE := True;

Теперь, когда вам необходимо проверить "запущенность" компонент в среде Delphi, просто проверьте данный флаг. [000604]


Delphi 1

Определение работы Delphi II

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

function DelphiIsRunning : boolean;
var
H1, H2, H3, H4 : Hwnd;
const
A1 : array[0..12] of char = 'TApplication'#0;
A2 : array[0..15] of char = 'TAlignPalette'#0;
A3 : array[0..18] of char = 'TPropertyInspector'#0;
A4 : array[0..11] of char = 'TAppBuilder'#0;
T1 : array[0..6] of char = 'Delphi'#0;
begin
H1 := FindWindow(A1, T1);
H2 := FindWindow(A2, nil);
H3 := FindWindow(A3, nil);
H4 := FindWindow(A4, nil);
Result := (H1 <> 0) and (H2 <> 0) and (H3 <> 0) and (H4 <> 0);
end;

initialization
if not DelphiIsRunning then
begin
AboutBox := TAboutBox.Create(nil);
AboutBox.ShowModal;
AboutBox.Free;
Halt;
end;
end.

Самая большая каверза, которую я обнаружил в данном методе, заключается в том, что когда вы запускаете программу с данным кодом, она работает из-под Delphi (что, в прочем, нам необходимо), но она будет работать и в том случае, когда программа запущена не из-под Delphi, а Delphi также загружена и работает параллельно. [000748]


Delphi 1

Имитация Delphi IDE

Во-первых, необходимо проверить, загружена ли Delphi - используйте FindWindow для поиска окна с именем класса TAppBuilder. Если оно загружено, FindWindow вернет вам дескриптор. Если нет, выполняйте WinExec и снова используйте FindWindow для получения дескриптора.

Для получения доступа к главному меню Delphi используйте GetMenu. "Пробегитесь" по дереву меню до тех пор, пока не найдете желаемый пункт. После получения ID пункта меню, вы можете посылать сообщение WM_COMMAND, дающее тот же эффект, что и нажатие на этот пункт. Ниже приведен пример вышесказанного. Для его создания, расположите на новой форме панель, выровняйте ее по верху (свойство Align = alTop) и разместите на ней кнопку. Расположите на форме компонент outline и установите его свойство Align в alClient. Поместите на форме компонент OpenDialog и настройте его на открытие файлов с расширением .EXE. Затем используйте код, приведенный ниже. Данный пример запустит определенную вами программу и отобразит структуру ее меню в outline. Располагая идентификаторами пунктов (IDs) меню чужой программы (в нашем случае Delphi) в компоненте outline, вы запросто можете управлять этой программой. Или, что еще интереснее, вы можете "пробежаться" по меню, используя те же методы, и найти нужный ID во время выполнения программы. Кто знает, может новая версия Delphi будет содержать другие пункты (ID) меню.

...
private
{ Private declarations }
InstHandle : Word;
WndHandle : hWnd;
function EnumFunc(H : HWnd) : Word;
...
implementation USES ShellApi;
{$R *.DFM}

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.Button1Click(Sender: TObject);
VAR
Cmd : ARRAY[0..255] OF Char;

procedure AddChildMenus(Loc, Han : Integer);
VAR
MText : ARRAY[0..255] OF Char;
N : Integer;
ID : Word;
NuLoc : Integer;
BEGIN
FOR N := 0 TO GetMenuItemCount(Han)-1 DO
BEGIN
Id := GetMenuItemID(Han, N);
GetMenuString(Han, N, MText, 255, MF_BYPOSITION);
IF ID = $FFFF THEN
BEGIN
NuLoc := Outline1.AddChild(Loc, StrPas(MText));
AddChildMenus(NuLoc, GetSubMenu(Han, N));
END
ELSE
Outline1.AddChild(Loc, StrPas(MText) + ' {' + IntToStr(Id) +'}');
END;
END;
begin
WITH OpenDialog1 DO
IF Execute THEN
BEGIN
StrPCopy(Cmd, Filename);
InstHandle := WinExec(Cmd, SW_SHOW);
WndHandle := 0;
IF InstHandle >= 32 THEN
EnumWindows(@TForm1.EnumFunc, LongInt(Self));
IF WndHandle <> 0 THEN
BEGIN
SetWindowText(WndHandle, 'Title changed by KNOWEXEC');
Outline1.Clear;
Outline1.Add(0, 'menu');
AddChildMenus(1, GetMenu(WndHandle));
END;
END;
end;

[000650]


Delphi 1

Запуск Delphi с CD-ROM

Инструкции для запуска Delphi с CD-ROM

Delphi может быть запущена непосредственно с CD-ROM. Тем не менее, перед запуском Delphi с CD-ROM, настоятельно рекомендуем соблюсти требования минимальной инсталляции Delphi.

Для минимальной установки требуется 33Мб свободного дискового пространства.

Для запуска с CD-ROM требуется 9MB свободного дискового пространства.

Для конфигурирования системы для запуска Delphi с CD-ROM,

  1. Скопируйте все файлы, находящиеся в каталоге компакта \RUNIMAGE\WINDOWS, в каталог Windows вашего жесткого диска.
  2. Скопируйте все файлы, находящиеся в каталоге компакта \RUNIMAGE\WINDOWS\SYSTEM, в системный каталог Windows вашего жесткого диска.
  3. Откройте файл DELPHI.INI в любом текстовом редакторе, например Windows Notepad. Найдите секцию с именем [Globals]. Создайте строчку с переменной PrivateDir и значением, указывающим на записываемый диск, желательно на локальный.
Для примера, если в качестве значения переменной с именем DELPRIV выбран диск C:, соответствующая секция файла DELPHI.INI должна выглядеть примерно так:

  [Globals]
  PrivateDir=C:\DELPRIV\
Теперь Delphi может быть запущен с каталога \RUNIMAGE\DELPHI\BIN directory вашего CD-ROM.

Изменение компонентов

Чтобы получить возможность изменения библиотеки компонентов при запуске Delphi с CD-ROM, на записываемом диске должна существовать копия библиотеки компонентов. Используйте в качестве руководства следующие шаги:

  1. Скопируйте COMPLIB.DCL с каталога CD \RUNIMAGE\DELPHI\BIN в подходящий каталог на вашем жестком диске.
  2. Запустите Delphi.
  3. Войдите в меню Options и выберите пункт Open Library.
  4. Задайте каталог и имя файла для скопированного на жесткий диск COMPLIB.DCL.
[000777]


Delphi 1

Удаление Delphi 1

Удаление Delphi (16 бит)

Содержание

Введение
A) Удаление каталогов
B) Удаление Программной Группы (Program Group)
C) Удаление .INI-файлов
D) Редактирование WIN.INI
E) Редактирование WINHELP.INI
F) Редактирование вашего AUTOEXEC.BAT
G) Удаляем файлы, расположенные в каталогах WINDOWS и WINDOWS\SYSTEM

Введение

Данный документ описывает процесс "удаления" Delphi из вашей системы. Хорошей идеей является сохранение ваших системных файлов, поскольку нам частенько понадобиться использовать команду 'удалить'.

Данный документ подразумевает, что продукт был установлен на диске "C:", с каталогами, заданными по умолчанию и полными (также по умолчанию) опциями установки. Любые отклонения от опций установки, заданных по умолчанию, может потребовать установок или изменений в приведенной инструкции.

A) Удаление каталогов

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

Если вы хотите удалять каталоги с помощью соответствующих команд DOS, смотрите расположенную ниже секцию 1, если с помощью Windows, смотри секцию 2.

  1. Чтобы стереть каталоги на вашем жестком диске в системе с DOS версии 6.0 и выше, вам необходимо перейти в корневой каталог (например, C:\> ), ввести команду DELTREE <DIR NAME> и нажать Enter (Пример: C:\>deltree delphi). Нажмите Yes в появившейся подсказке на вопрос об удалении вложенных каталогов (смотрите ниже список подлежащий удалению каталогов). Для версий DOS ниже 6.0, вам необходимо переходить внутрь каждого каталога и набирать DEL *.* до тех пор, пока все каталоги не опустеют. После этого DOS позволит вам удалить имя каталога с помощью команды RD <DIR NAME>.
  2. Для Windows загрузите File Manager. Используя File Manager, выберите каталог <DIR NAME>. Нажмите клавишу Delete. Нажмите Yes в появившейся подсказке на вопрос об удалении вложенных каталогов.

    Каталоги, подлежащие удалению:

             C:\Delphi                    C:\Rptsmith
         C:\Rs_run                    C:\Dbd
         C:\Iblocal                   C:\Idapi
       * C:\Informix

       * - только для версии Client/ Server
B) Удаление Программной Группы (Program Group)

Для удаления программной группы 'Delphi' в Windows 3.1 или Windows NT, выделите группу, не открывая ее, и нажмите клавишу Delete. В Windows 95 каталоги были удалены в предыдущей секции.

C) Удаление .INI-файлов

Удалите следующие .INI-файлы из вашего каталога \WINDOWS (ПРЕДУПРЕЖДЕНИЕ: если вы имеете любые другие продукты Borland или любые программы, использующие ODBC, сохраните указанные в списке ниже .INI-файлы перед тем как их удалить. После этого протестируйте все другие программы на предмет их нормальной работы!):

                 DELPHI.INI
    BORHELP.INI
    DBD.INI
                INTERBAS.INI
             * ODBC.INI
             * ODBCINST.INI
             * ODBCISAM.INI
    RPTSMITH.INI
    RS_RUN.INI
    RS_SQLIF.INI
    VSL.INI
    MULTIHLP.INI

            * - файлы, используемые ODBC-приложениями
D) Редактирование WIN.INI

Сохраните ваш WIN.INI-файл. Затем, в каталоге \WINDOWS, удалите следующие секции из вашего WIN.INI-файла (ПРЕДУПРЕЖДЕНИЕ: Если любая другая программа использует Paradox Engine, IDAPI, или Database Desktop, удаляйте перечисленные строки в соответствии с их потенциальным использованием!):

    [DDE Servers]
    DBD=C:\DBD\DBD

    [DBD]
    WORKDIR=C:\DBD
    PRIVDIR=C:\DBD\DBDPRIV

    [Interbase]
    RootDirectory=C:\IBLOCAL

              * [IDAPI]
    DLLPATH=C:\IDAPI
    CONFIGFILE01=C:\IDAPI\IDAPI.CFG

      * [Borland Language Drivers]
    LDPath=C:\IDAPI\LANGDRV

     * - НЕ удаляйте это, если другие программы используют IDAPI
Не забудьте сохранить ваш новый WIN.INI.

E) Редактирование WINHELP.INI

Удалите следующие строки из WINHELP.INI, расположенного в вашем каталоге WINDOWS:

    BDECFG.HLP=C:\IDAPI
    DBD.HLP=C:\DBD
    DELPHI.HLP=C:\DELPHI\BIN
    WINAPI.HLP=C:\DELPHI\BIN
    CWG.HLP=C:\DELPHI\BIN
    CWH.HLP=C:\DELPHI\BIN
    LOCALSQL.HLP=C:\DELPHI\BIN
    VQB.HLP=C:\DELPHI\BIN
    SQLREF.HLP=C:\IBLOCAL\BIN
    WISQL.HLP=C:\IBLOCAL\BIN
    RPTSMITH.HLP=C:\rptsmith
    RS_DD.HLP=C:\rptsmith
    SBL.HLP=C:\rptsmith
    RS_RUN.HLP=C:\rptsmith
    RCEXPERT.HLP=C:\DELPHI\RCEXPERT
    DRVDBASE.HLP=C:\WINDOWS\SYSTEM
    DRVPARDX.HLP=C:\WINDOWS\SYSTEM
    ODBCINST.HLP=C:\WINDOWS\SYSTEM
F) Редактирование вашего AUTOEXEC.BAT

Во-первых, сохраните ваш AUTOEXEC.BAT файл. Затем редактируйте ваш AUTOEXEC.BAT и удалите C:\IBLOCAL\BIN; и C:\IDAPI; из переменной PATH, если, конечно, они присутствуют.

(Пример:
  (OLD)  PATH = C:\;C:\WINDOWS;C:\DOS;C:\IDAPI;C:\IBLOCAL\BIN;
  (NEW)  PATH = C:\;C:\WINDOWS;C:\DOS;)
Не забудьте сохранить ваш новый AUTOEXEC.BAT.

G) Удаляем файлы, расположенные в каталогах WINDOWS и WINDOWS\SYSTEM

Пожалуйста помните: Данные файлы указаны ТОЛЬКО для ссылки. Удалять их настоятельно НЕ рекомендуется. Удаление некоторых файлов, используемых другими программами, может привести к нестабильной работе вашей системы или даже к ее разрушению.

ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!

Множество файлов, указанных в данной секции, являются общими для многих программ. Удалив их, можно лишить работоспособности другие программы, ВКЛЮЧАЯ WINDOWS. Если вы все же хотить удалить файлы из данных каталогов, то делайте это ТОЛЬКО на свое собственное усмотрение. Возможным решением данной проблемы является удаление файла с последующей проверкой работоспособности ВСЕХ программ вашей системы. Копии всех указанных ниже файлов располагаются на Delphi CD в каталоге runimage. Вы можете в дальнейшем скопировать файлы с CD, если это потребуется после их случайного удаления. Пожалуйста, будьте осторожными.

ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!ПРЕДУПРЕЖДЕНИЕ!!!!

Файлы, расположенные или обновленные Delphi в вашем каталоге \WINDOWS:

    DELPHI.CBT		M3OPEN.DLL
    M3OPEN.EXE		MBW.EXE
    MFTP.EXE		MHPARPA.DLL
    MNETONE.EXE		MNOVLWP.DLL
    MPATHWAY.DLL		MPCNFS.EXE
    MPCNFS2.EXE		MPCNFS4.DLL
    MSOCKLIB.DLL		MVWASYNC.EXE
    MWINTCP.EXE		WINSOCK.DLL
Файлы, расположенные или обновленные Delphi в вашем каталоге \WINDOWS\SYSTEM:
    BIBAS04.DLL		BIFLT04.DLL
    BIMDS04.DLL		BIPDX04.DLL
    BIPDX04.HLP		BIUTL04.DLL
    BIVBX11.DLL		BLBAS04.DLL
    BLINT04.DLL		BLINT04.HLP
    BLMDS04.DLL		BLODBC.LIC
    BLUTL04.DLL		BOLE16D.DLL
    BTRV110.DLL		BWCC.DLL
    CHART2FX.VBX		COMPOBJ.DLL
              * COREWIN.DLL		CTL3D.DLL
    CTL3DV2.DLL	              * DBNMP3.DLL
    DRVACCSS.HLP		DRVBTRV.HLP
    DRVDBASE.HLP		DRVEXCEL.HLP
    DRVFOX.HLP		DRVTEXT.HLP
    GAUGE.VBX	             * LDLLSQLW.DLL
    MSJETDSP.DLL		MULTIHLP.DLL
    NWCALLS.DLL		NWIPXSPX.DLL
             * NWNETAPI.DLL		ODBC.DLL
    ODBCADM.EXE		ODBCCURS.DLL
    ODBCINST.DLL		ODBCINST.HLP
    OLE2.DLL			OLE2.REG
    OLE2CONV.DLL		OLE2DISP.DLL
    OLE2NLS.DLL		OLE2PROX.DLL
              * ORA6WIN.DLL	             * ORA7WIN.DLL
    PICT.VBX			PXENGCFG.EXE
    PXENGWIN.DLL		QEBI.LIC
    RED110.DLL		SIMADMIN.DLL
    SIMBA.DLL		STDOLE.TLB
    STORAGE.DLL		STRESS.DLL
    SWITCH.VBX		TXTISAM.DLL
    TYPELIB.DLL	              * W3DBLIB.DLL
    XBS110.DLL		XLSISAM.DLL

          * - только для версии Client/ Server
Все .BOR-файлы являются сохраненными первоначальными файлами, Delphi переименовывает их и заменяет обновленными или измененными, поэтому вы можете в дальнейшем ими воспользоваться, сравнить с текущими и, при необходимости, восстановить. Если вы установили любое программное обеспечение после того, как файл .BOR был создан, он может быть удален.

[000834]


Невидимые элементы управления

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

Выберите TTable в Инспекторе Объектов.
Щелкните один раз на заголовке формы, чтобы передать ей фокус.
Нажмите Ctrl-X
Нажмите Ctrl-V
Ваш TTable как по-волшебству снова появится в позиции 0,0.

- Ralph Friedman [000993]


Delphi 1

Директивы компилятора, способные увеличить скорость

...скорость может упасть из-за применения динамических массивов.

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

{$R-} {Range checking off - проверка диапазона}
{$S-} {Stack checking off - проверка стека}
{$A+} {Word align data - "выравнивание слов"}

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


Delphi 1

Hard mode без перерыва

При отладке я наткнулся на сообщение, похожее на системное сообщение Windows, звучащее приблизительно так: "Unable to stop at breakpoint due to Hard Mode" (невозможно остановиться в точке прерывания из-за Hard Mode - дословно "Тяжелый Режим").

Чья это страшилка, Windows или Delphi, и что это такое - "Hard Mode"?

Это Windows. Есть определенные легальные способы заставить перейти Windows в "Hard Mode". В этом режиме отладчик прервать невозможно. Тем не менее вы могли бы попробовать знаменитый "Маневр Мебиуса". Он заключается в установке дополнительной точки останова на строке *перед* той, которая сообщает системе о переходе в режим Hard. Вызов системного модального диалога обычно заставляет систему выйти из этого режима, после чего вторая точка останова сработает как обычно. Простое шаманство...

Mike Scott Mobius Ltd. [000395]


Delphi 1

Вывод объекта отладки

...а вы пробовали после имени переменной добавить ",r", это должно отоборазить структуру с именами и их значениями?

В окне Watch все таже длинная строка ...

А вы пробовали в Evaluate/Modify покрутить полосу прокрутки? [000410]


Таблицы строк

Ресурсы в виде таблиц строк (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;

[000228]


Включение JPEG в EXE-файл

Я начинающий Delphi программист и только что приступил к изучению этой замечательной среды разработчика; сейчас передо мной стоит задача распространения моей самой первой программы. Начиная с третьей версии, Delphi содержит модуль jpeg, позволяющий работать с этим форматом изображений, и у меня встала задача включить jpeg-графику в мой исполнимый файл для последующего использования в программе, но как это осуществить я пока не знаю.

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

Шаг первый:

Создайте файл сценария ресурса (*.RC) в обычном текстовом редакторе типа Notepad и добавьте следующую строку:

1  RCDATA  "MyPic.jpg"

Первый элемент является просто индексом ресурса. Второй элемент указывает на определенный пользователем ресурс. Третий, он же последний элемент, является именем jpeg-файла.

Шаг второй:

Для компиляции ресурса в .RES-файл используйте Borland Resource Compiler, BRCC32.EXE. В командной строке MS-DOS введите:

BRCC32 MyPic.RC

Это создаст файл ресурса с именем MyPic.RES.

Шаг третий:

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

{$R *.DFM}
{$R MyPic.RES}

Шаг четвертый:

Добавьте следующий код к вашему проекту (для этого я создал процедуру):

procedure LoadJPEGfromEXE;

var
MyJPG : TJPEGImage; // Объект - JPEG
ResStream : TResourceStream; // Объект - поток ресурсов

begin
try
MyJPG := TJPEGImage.Create;
ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA);
MyJPG.LoadFromStream(ResStream); // Что!? Да, это просто!
Canvas.Draw(12,12,MyJPG); // сделайте это, чтобы увидеть что это действительно работает!
finally
MyJPG.Free;
ResStream.Free;
end;
end;  // procedure

Обратили внимание на второй параметр процедуры CreateFromID объекта TResourceStream? Это просто индекс ресурса. Вы можете включить более одного jpeg-изображения в исполняемый модуль приложения, просто добавляя в .RC-файл строчку с другим индексом для каждого включаемого изображения.

Шаг пятый:

Вызовите процедуру, запустите программу и вуаля! Дело сделано. [000229]


Проигрывание wave-файла, помещенного в ресурс

Я пытаюсь проиграть wave-файл при щелчке на кнопке моего Delphi-приложения. Я установил звуковой файл и воспользовался вызовом API функции PlaySound(), но мне хотелось бы поместить его в ресурс приложения, т.е. "вложить" его в EXE-файл и проигрывать его оттуда.

Во первых, вам необходимо скомпилировать необходимый ресурс (например, с помощью Resource Workshop) и включить туда ваш WAVE-файл. Затем для его вызова и проигрывания используйте следующий код:

var FindHandle, ResHandle: THandle;
ResPtr: Pointer;
begin
FindHandle:=FindResource(HInstance, '<Имя вашего ресурса>', '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 3):

PlaySound('S1', HInstance, SND_RESOURCE or SND_ASYNC);

где S1 - ID (идентификатор) звука.

Эта единственная строчка кода сама ищет, загружает, блокирует, разблокирует и освобождает ресурс.

[000244]


Несколько иконок в Delphi exe?

Кто-нибудь знает как с помощью Delphi присвоить выполнимому файлу сразу несколько иконок? Т.е. так, что если вы ассоциируете тип файла и просматриваете ваше скомпилированное приложение, вы видите несколько возможных иконок, но, к сожалению, опция Project|Options|Application|Icon позволяет установить только одну иконку.

Просто создайте файл ресурса (.res), для примера, в Image Editor, и сохраните в нем ваши иконки. Затем подлинкуйте ресурс директивой компилятора $R и ваше приложение будет иметь столько иконок, сколько вы их создадите.

[000303]


Мультиязыковое приложение

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

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

Вот некоторый код, дающий представление об этом методе:

unit French1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
StringIndex : Integer;
implementation

{$R *.DFM}

{$R MULTLANG.RES}

{ Вот содержимое ресурсного файла для этого проекта:
1, "Attention"
2, "No Condition definition selected!"
3, "Always"
4, "Cannot delete the 'always' condition."
5, "Confirmation"
6, "Delete the condition?"
7, "Yes"
8, "No"
9, "Attention"
10, "Pas de condition Selectionnйe"
11, "Toulours"
12, "Ne peux effacer la condition 'Toujours'"
13, "Confirmation"
14, "Effacer cette condition?"
15, "&Oui"
16, "&Non"
}

procedure TForm1.FormActivate(Sender: TObject);
var
{inifile : TIniFile; Опционально}
ProgramLanguage : String;
begin
{ Устанавливаем французский язык }
ProgramLanguage := 'fra';
{ Дополнительно вы можете получить текущий язык из Win.INI:}
{inifile := TInifile.Create('WIN.INI');
ProgramLanguage := inifile.ReadString('intl', 'sLanguage', 'enu');
inifile.Free;}
{ Простите за то, что я привожу здесь несколько языков, указанные
ниже находились в файле setup.inf моей операционной системы.

dan = Danish
nld = Dutch
enu = English (American)
eng = English (International)
fin = Finnish
fra = French
frc = French Canadian
deu = German
isl = Icelandic
ita = Italian
nor = Norwegian
ptg = Portuguese
esp = Spanish
esn = Spanish (Modern)
sve = Swedish

}
if ProgramLanguage = 'enu' then
begin
StringIndex := 0;
end
else
if ProgramLanguage = 'fra' then
begin
StringIndex := 8;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i,j,k : integer;
DialogForm : tform;
begin
Application.NormalizeTopMosts;
{No Condition definition selected!"}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+2),mtWarning,[mbOK]);
{Attention}
DialogForm.caption := LoadStr(StringIndex + 1);
DialogForm.showmodal;
Application.RestoreTopMosts;
{Cannot delete the 'always' condition.}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+4),mtWarning,[mbOK]);
{Always}
DialogForm.caption := LoadStr(StringIndex + 3);
DialogForm.showmodal;
Application.RestoreTopMosts;
{Delete the condition?}
DialogForm := CreateMessageDialog(LoadStr(StringIndex+6),mtInformation, [mbYes, mbNo]);
{confirmation}
DialogForm.caption := LoadStr(StringIndex + 5);
for j := 0 to DialogForm.controlCount-1 do
begin
if DialogForm.controls[j] is tButton then
with tButton(DialogForm.controls[j]) do
begin
if caption = '&Yes' then caption := LoadStr(StringIndex+7);
if caption = '&No' then caption := LoadStr(StringIndex+8);
end;
end;
DialogForm.showmodal;
end;

end.

[000309]


Delphi 1

Загрузка строк из RES-файла

Используйте функцию LoadString (Windows API). Это должно выглядеть приблизительно так:

var
MyString: String;
Buffer: array[0..255] of Char;

...
LoadString(hInstance, 1234, Buffer, 255);
MyString := StrPas(Buffer);

где 1234 - ID номер необходимой строки. [000431]


Одной строкой

Сохранение ресурсов системы

...кстати, для себя я решил еще одну проблему. Вместо использования статических элементов управления в многостраничном NoteBook, я использую компоненты Label, при щелчке на которых появляется небольшая модальная форма, элементы которой используют ресурсы. Введенная информация передается в Label на страницу NoteBook. Таким образом ресурсы используются многократно и являются своего рода параметрами, передающимся подпрограмме. При этом используется только один дескриптор окна. Фактор 15! [000492]


Delphi 2

Преобразование 16-битного DCR в 32-битный

Возможно ли преобразование 16-битного файла ресурсов, содержащего палитру иконок компонентов в 32-битный файл?

Вот двушаговый процесс.

Сначала запустите Resource Workshop и загрузите 16-битный файл ресурсов. Сохраните его как .RC-файл (исходный файл ресурсов) и выйдите из RW.

Снова запустите RW. Укажите в настройках 32-битный режим работы с ресурсами. Откройте сохраненный на предыдущем этапе ваш .RC-файл. Снова сохраните его как .RES-файл (на этом этапе вы могли бы изменить его имя, чтобы указать на его 32-битный формат) и выйдите из RW.

У меня работает...

Успехов,
Dr. Bob (DrBob@pi.net) [000773]


Загрузка изображения/курсора из RES-файла

Загрузка изображений и курсоров из RES-файлов

Изображения и курсоры могут храниться в файлах ресурсов (RES) и прилинковываться (связаваться) к EXE-файлу вашего приложения. RES-файлы могут создаваться с помощью Delphi утилит Image Editor и Borland Resource Workshop, входящие в поставку Delphi RAD Pack. Изображения и курсоры, хранимые в RES-файлах (после упаковки их в EXE или DLL) могут быть извлечены с помощью API функций LoadBitmap и LoadCursor соответственно.

Загрузка изображений

Функция API LoadBitmap определена следующим образом:

function LoadBitmap(Instance: THandle; BitmapName: PChar): HBitmap;

Первый параметр должен содержать дескриптор модуля (EXE или DLL), содержащего файл RES, из которого вы хотите получить ресурс. Delphi хранит дескриптор запущенного EXE-файла в глобальной переменной с именем Hinstance. В приведенном ниже примере мы предполагаем, что модуль, из которого мы пытаемся загрузить изображение, - ваше приложение. Тем не менее, модуль мог бы быть другим EXE- или DLL-файлом. Следующий пример загружает изображение с именем BITMAP_1 из RES-файла, прилинкованного к EXE-файлу приложения:

procedure TForm1.Button1Click(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
Bmp.Handle := LoadBitmap(HInstance,'BITMAP_1');
Canvas.Draw(0, 0, Bmp);
Bmp.Free;
end;

Имеется один недостаток использования API вызова LoadBitmap: LoadBitmap все же является API вызовом Windows 3.0, и грузит изображение только как DDB (Device Dependent Bitmaps). Это может вызвать проблемы с цветовой палитрой при загрузке DIB (Device Independent Bitmaps) из RES-файла. Приведенный ниже код может использоваться для извлечения DIB-ов из RES-файлов. Данный код загружает изображение как общий ресурс, передает его в поток, после чего делает Delphi вызов LoadFromStream, реализующий палитру автоматически.

procedure TForm1.Button1Click(Sender: TObject);
const
BM =  $4D42;  {Идентификатор типа изображения}
var
Bmp: TBitmap;
BMF: TBitmapFileHeader;
HResInfo: THandle;
MemHandle: THandle;
Stream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
begin
BMF.bfType := BM;
{Ищем, загружаем и блокируем ресурс, содержащий BITMAP_1}
HResInfo := FindResource(HInstance, 'BITMAP_1', RT_Bitmap);
MemHandle := LoadResource(HInstance, HResInfo);
ResPtr := LockResource(MemHandle);

{Создаем Memory-поток, устанавливаем его размер, записываем
туда заголовок изображения и, наконец, само изображение }
Stream := TMemoryStream.Create;
ResSize := SizeofResource(HInstance, HResInfo);
Stream.SetSize(ResSize + SizeOf(BMF));
Stream.Write(BMF, SizeOf(BMF));
Stream.Write(ResPtr^, ResSize);

{Освобождаем поток и сбрасываем его позицию в 0}
FreeResource(MemHandle);
Stream.Seek(0, 0);

{Создаем TBitmap и загружаем изображение из MemoryStream}
Bmp := TBitmap.Create;
Bmp.LoadFromStream(Stream);
Canvas.Draw(0, 0, Bmp);
Bmp.Free;
Stream.Free;
end;

Загрузка курсоров

Функция API LoadCursor определена следующим образом:

function LoadCursor(Instance: THandle; CursorName: PChar): HCursor;

Первый параметр Instance должен содержать дескриптор модуля, содержащего файл RES. Как и пример, приведенный выше, данный пример предполагает, что модуль, из которого мы пытаемся загрузить курсор, - ваше приложение. Второй параметр - имя курсора. В секции interface сделайте следующее объявление:

const
crMyCursor = 5; {Другие модули могут также использовать эту константу}

Затем добавьте следующие две строчки к обработчику события формы OnCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crMyCursor] := LoadCursor(HInstance, 'CURSOR_1');
Cursor := crMyCursor;
end;

или же вы можете изменить один из стандартных курсоров Delphi как показано ниже (константы Cursor описаны в электронной справке в статье Cursors Property):

procedure TForm1.FormCreate(Sender: TObject);
begin
{Данный пример изменяет курсор SQL Hourglass}
Screen.Cursors[crSQLWait] := LoadCursor(HInstance, 'CURSOR_1');
end;

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

[000840]


Delphi 1

Эксперт ресурсов

Эксперт ресурсов (Resource Expert): что это и как это установить и использовать.

Что есть Resource Expert

Resource Expert является встраиваемым (add-on) экспертом Delphi и является частью Delphi Rad Pack. Эксперт помогает программисту в портации в существующие Delphi-проекты ресурсов, преобразования диалогов и сценарий ресурсов меню для использования в традиционных приложениях Windows. Диалоговые ресурсы и их содержание преобразовываются в формы Delphi с аналогичными элементами управления, также преобразуемые в компоненты Delphi.

Как установить Resource Expert

Resource Expert устанавливается c помощью процедуры установки Delphi Rad Pack Resource Workshop 4.5. После установки, он включается в библиотеку компонентов Delphi, доступен как элемент Delphi меню Help и на закладке Experts в диалоге Forms Gallery (галлерея форм). Установка файлов Resource Expert может производиться как из среды Windows, так и с помощью коммандной строки Windows 95 и Windows NT.

Для установки файлов Resource Expert в среде Windows,

  1. Запустите процедуру установки Borland Resource Workshop.
  2. В третьем диалоге, названном 'Resource Workshop - Resource Expert Options', убедитесь, что пункт (CheckBox) 'Install Resource Expert' отмечен.
  3. В поле 'Install to:' укажите каталог расположения файлов Resource Expert, по умолчанию задано C:\DELPHI\RCEXPERT. Измените это по вашему усмотрению.
  4. Остальная часть процесса установки Resource Workshop остается без изменений.
Для установки файлов Resource Expert из командной строки, используйте следующие команды:
  1. MD C:\DELPHI\RCEXPERT
  2. CD C:\DELPHI\RCEXPERT
  3. E:\INSTALL\RW\UNPAQ -X E:\INSTALL\RW\RESEXP.PAK
Примечание: в последней команде в приведенном списке предполагаем, что диск E: является приводом CD-ROM, содержащим установочный компакт Rad Pack.

После установки файлов Resource Expert библиотеку компонентов Delphi должна быть пересобрана. Для этого,

  1. Загрузите Delphi.
  2. Выберите Options|Install Components.
  3. Щелкните на кнопке Add....
  4. При появлении диалога Add Module, введите полный путь к файлу rcexpert.pas, или найдите его, щелкнув на кнопке Browse.....
  5. Наконец, в диалоге Install Components Dialog нажмите кнопку OK.
Как использовать Resource Expert

Для преобразования сценария ресурса (Resource scripts), компиляции ресурса, в нормальной ситуации необходимо наличие всех всех исходных файлов. Они должны включать .RC, .MNU, или .DLG файл(ы) и любые .H или .PAS-файлы, на которые они ссылаются. Сценарии ресурса обычно используют WINDOWS.H и BWCC.H. Данные файлы обычно располагаются в каталогах типа \BC4\INCLUDE или \BP7\UNITS. Resource Expert поддерживает языковые расширения RC, определяемые в Resource Workshop.

Кроме того, Resource Expert может быть вызван через пункт меню Help|Resource Expert или со страницы Experts диалога Forms Gallery. Вызов последнего возможен, если отмечен флажок напротив опции 'Use on new form' страницы Preferences диалога Environment Options.

После запуска Resource Expert щелкните на кнопке 'Next', этим вы пропустите страницу презентации эксперта. Вторая страница эксперта позволяет пользователю выбрать для преобразования сценарий ресурса. Могут быть выбраны несколько сценариев при условии, если все они находятся в одном каталоге. Конкретный тип сценария (.RC, .DLG или .MNU) может быть выбран через выпадающий список 'List Files of Type'. После того как сценарий для преобразования выбран, щелкните снова на кнопке 'Next'. Третья страница представляет собой страницу с единственным полем редактирования 'Include Path'. Введите список каталогов, содержащих .H, .INC, или включенные .PAS-файлы, используемые сценариями ресурса (если имеются). Каждое имя каталога должно разделяться точкой с запятой. И снова для продолжения нажмите кнопку 'Next'. На четвертой, последней странице эксперта станет доступной кнопка 'Convert'. Щелчок на ней фактически запустит процесс преобразования. Если сценарий ресурса содержит много диалогов, уберите галочку напротив пункта 'Show all forms', это поможет увеличить скорость преобразования и уменьшит потребности в системных ресурсах.

Если в процессе преобразования была обнаружена синтаксическая ошибка, ошибочный блок будет пропущен, а процесс преобразования продолжится со следующего блока. Возникшие ошибки журналируются в файле ERRLOG.TXT и выводятся в окне редактора Delphi. По окончании процесса преобразования для каждого ресурса диалога будет создана отдельная форма. Для ресурсов меню будет создана простая форма, содержащая компонент TMainMenu с теми же пунктами, что и преобразовываемый ресурс. Если перед началом преобразования какой-либо проект был активен, к нему будут добавлены все преобразованные формы. Каждая форма теперь может быть отредактирована и использована так, как будто бы это была любая форма Delphi.

[000842]


Delphi 1

Создание 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 [000854]


Сохранение пользовательских настроек

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

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

const FileName = 'Form1.stm' ;

constructor TForm1.Create( AOwner : TComponent ) ;
begin
if FileExists( FileName ) then begin
CreateNew( AOwner ) ;
ReadComponentResFile( FileName, Self ) ;
end else
inherited Create( AOwner ) ;

{ поместите здесь код в стиле 'OnCreate' }
end ;

procedure TForm1.FormDestroy(Sender: TObject);
begin
WriteComponentResFile( FileName, Self ) ;
end;

Имейте в виду, что это не вызывает OnCreate. В действительности, вам OnCreate и не нужен, поскольку сюда вы можете поместить код, необходимый в обработчике OnCreate; данный код следует поместить после конструктора Create, как и указано в комментарии.

- Mike Scott [000855]


Delphi 2

16/32-битные RES-файлы

Мои RES-файлы содержат строки и изображения, могу ли я использовать их в 32-битном варианте?

Сохраните RES-файл как RC-файл и используйте BRCC32 для создания 32-битного RES-файла.

- Pat Ritchey [000907]


Хранение данных в 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 [000964]


Пример защиты типа SHAREWARE

Приведу небольшой участок кода, позволяющий быстро создать защиту для 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 +
'ЗАРЕГИСТРИРУЙТЕСЬ !!');
Close;
end;
end;

Преимущество данного метода в том, что пользователь может воспользоваться всей функциональностью программы, но только до момента закрытия программы и перезапуска системы! Вся хитрость заключается в сохранении некоторой строки в системных глобальных переменных ("атомах") и последующей проверке ее в таблице "атомов" системы. [000298]


Как стереть самого себя

Den is Com советует:

// проверено и работает для WIN 9x. Не работает в WinNT

При работе программы происходит блокировка исполняемого файла программы на диске, до завершения работы программы. Данный код позволяет программе стереть саму себя с диска. При этом если программа уже загрузилась в память, то может работать и работать. Метод действия: создаётся временный bat файл в временной директории на диске, который удаляет программу и удаляет себя сам. При использовании кода в защите желательно использовать хотя бы простейшую шифровку текстовых строчек XOR-ом - они хорошо просматриваются диссассемблером и разумеется, хакеру не составит труда обнаружение защиты.

var Filename:String;
aTempBuf:array[0..MAX_PATH] of char;
bat_file:String;
f:TextFile;
si:TStartUpInfo;
pi:TProcessInformation;
begin
FileName:=Application.ExeName;
if GetShortPathName(PChar(FileName),aTempBuf,Sizeof(aTempBuf)-1)>0 then
 FileName:=StrPAs(aTempBuf);

GetEnvironmentVariable('TEMP',aTempBuf,MAX_PATH);
bat_file:=StrPas(aTempBuf)+'\'+'delself.bat';
if GetShortPathName(PChar(bat_file),aTempBuf,Sizeof(aTempBuf)-1)>0 then
bat_file:=StrPAs(aTempBuf);

AssignFile(f,bat_file);
rewrite(f);
Writeln(f,'@echo off');
Writeln(f,':try');
Writeln(f,'del '+FileName);
Write(f,'if exist '+FileName);
Writeln(f,' goto try');
Write(f,'del '+ bat_file);
CloseFile(f);
//Memo1.Lines.LoadFromFile(bat_file);

ZeroMemory(@si,sizeof(si));
si.cb:=sizeof(si);
si.wShowWindow:=SW_HIDE;
si.dwFlags:=STARTF_USESHOWWINDOW;
CreateProcess(nil,PChar(bat_file),nil,nil,False,IDLE_PRIORITY_CLASS or DETACHED_PROCESS,
nil,nil,si,pi);

Привожу полностью все файлы проекта:

Project1.dpr

program Project1;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Unit1.dfm

object Form1: TForm1
Left = 192
Top = 107
Width = 435
Height = 300
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 Button1: TButton
Left = 48
Top = 200
Width = 313
Height = 49
Caption = 'Del me !'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -32
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 0
OnClick = Button1Click
end
object Memo1: TMemo
Left = 48
Top = 16
Width = 305
Height = 169
TabOrder = 1
end
end

Unit1.pas

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}

procedure TForm1.Button1Click(Sender: TObject);
var Filename:String;
aTempBuf:array[0..MAX_PATH] of char;
bat_file:String;
f:TextFile;
si:TStartUpInfo;
pi:TProcessInformation;
begin
FileName:=Application.ExeName;
if GetShortPathName(PChar(FileName),aTempBuf,Sizeof(aTempBuf)-1)>0 then
FileName:=StrPAs(aTempBuf);

GetEnvironmentVariable('TEMP',aTempBuf,MAX_PATH);
bat_file:=StrPas(aTempBuf)+'\'+'delself.bat';
if GetShortPathName(PChar(bat_file),aTempBuf,Sizeof(aTempBuf)-1)>0 then
bat_file:=StrPAs(aTempBuf);

AssignFile(f,bat_file);
rewrite(f);
Writeln(f,'@echo off');
Writeln(f,':try');
Writeln(f,'del '+FileName);
Write(f,'if exist '+FileName);
Writeln(f,' goto try');
Write(f,'del '+ bat_file);
CloseFile(f);
Memo1.Lines.LoadFromFile(bat_file);

ZeroMemory(@si,sizeof(si));
si.cb:=sizeof(si);
si.wShowWindow:=SW_HIDE;
si.dwFlags:=STARTF_USESHOWWINDOW;
CreateProcess(nil,PChar(bat_file),nil,nil,False,IDLE_PRIORITY_CLASS or DETACHED_PROCESS,
nil,nil,si,pi);
end;

end.

[000806]


Защита программ перекрытием кода

Den is Com советует:

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

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

temp_string :='Den is Com';
asm
mov  ax,$05EB
@as: jmp @as-2
 end;
ShowMessage('Сообщение');

На первый взгляд это может сконфузить вас, но все это очень просто. Первая инструкция заносит "левое" значение в AX. Вторая делает переход на значение операнда команды MOV AX. '05EB' переводится как 'jmp$+5' (помните, что слова хранятся задом наперед) Этот переход перепрыгивает первый JMP и продолжает дальше по коду.Вероятно, не будет достаточно для защиты, но продемонстрирует технику. Взгляните на это как пример.

присваивание temp_string :='Den is Com' существенной роли не играет :), но может использоваться при отладке программы - хорошо присматривается при использовании дизассемблера. Скорее всего ваши первые шаги будут приводить к частому зависанию компьютера, но не отчаивайтесь - это того стоит. Попробуйте разработать свой способ сравнения строк (чаше всего ловятся именно эти инструкции), попробуйте замаскировать инструкции зависания компьютера и т.д. [000817]


Каталог вашего приложения I

Application.EXEName возвращает полное имя вашего приложения, включая диск и путь. Использование функции ExtractFilePath() с Application.EXEName в качестве параметра позволяет получить только диск и путь. Просто!
[000130]


Delphi 1

Каталог вашего приложения II

Application.ExeName содержит полный путь и имя вашего приложения.

Для получения самого пути, включая слэш '\', используйте функцию ExtractFilepath.

Перед использованием ChDir, MkDir и т.п. в Win31, вы должны удалить конечный слеш '\'. В Win95 такой проблемы нет (спасибо Mike Scott за данный совет). [000446]


Delphi 1

Каталог вашего приложения III

Два пути:

GetDir(0, S);

или

ExtractFilePath(ExpandFileName('.'));

-- Xavier [000746]


Каталог вашего приложения IV

Читатель пишет:

В "Советов по Delphi" в трех публикациях с заглавием "Каталог вашего приложения" (Раздел "Разное") перечислены методы, которые будут неверно работать например с isapi dll. Для решения этой проблемы я использую такой код:

procedure TWebModule1.WebModuleCreate(Sender: TObject);
var
SP: array[0..MAX_PATH-1] of char;
ScriptPath: string;
begin
SetString(ScriptPath, SP, GetModuleFileName(hInstance, SP, SizeOf(SP)));
ScriptPath := ExtractFilePath(ScriptPath);

// Здесь ваш код, использующий ScriptPath

end;

Best regards,
Yaroslav
oya@hotmail.ru
http://www.oya.hotmail.ru [000913]


16-разрядные приложения в Delphi 2-Х??

Вы не сможете создавать 16-битные программы, используя Delphi 2.0 и выше, только 32-битные. Хорошая новость в том, что (насколько я знаю) все версии Delphi 2 и выше поставляются на CD, содержащим впридачу и 16-битный Delphi 1.0. Вы должны установить его на компьютер или запустить непосредственно с CD, используя каталог Delphi16/RunImage. Имейте в виду, что ваш код не будет работать, если вы использовали специфические компоненты из закладки Win95 или WinAPI функции. Для того, чтобы сделать 16-разрядное приложение из 32-разрядного, вы должны скопировать *.dpr, *.dfm и *.pas файлы вашего приложения в другой каталог (только не копируйте файлы *.dcu, *.opt и *.res, генерируемые Delphi 2, иначе вы получите ошибку) и перекомпилировать ваш проект в Delphi 1.
[000132]


Как мне создать Internet-ссылку в диалоге "О программе"?

Недавно в одной программе я увидел интересный эффект. Как вы знаете, почти каждая программа имеет диалоговое окно "О программе" (About box), так вот, в этом диалоге был простой WWW-адрес типа "http://www.somewhere.com". Когда я перемещал мышь над этим адресом, он становился синим, ну прямо как в HTML-страничке! При щелчке на нем автоматически открывался браузер, установленный по умолчанию в системе, и осуществлялся переход по этому адресу. Кто-нибудь расскажет, как мне сделать такой трюк в моем собственном приложении?

Расположите на форме компонент Label, заголовок которого будет демонстрировать ваш URL (я назвал его URLLabel). Я также назначаю этому компоненту другой цвет, чтобы он отличался от остального текста, расположенного на форме. Затем создайте у нашего компонента обработчик события OnClick следующего вида:

// Как запустить браузер по http-адресу?

ShellExecute(Application.Handle,'open','http://www.somewhere.com',nil,nil,0);

Или же такого:

// Как запустить создание письма по указанному адресу?

ShellExecute(Application.Handle,'open','mailto:towho@mysite.com',nil,nil,0);

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

Для создания видимости ссылки, я присвоил свойству URLLabel.Cursor значение crAppStart.

Большое спасибо Александру Дзюба за полезные замечания.

Дополнение

Народ часто спрашивает где менять цвет лейблы, поэтому предлагаю немного дополнить ;-) раздел: Разное->Разное->Как мне создать Internet-ссылку в диалоге "О программе"?

Я делаю следующее

// Как запустить создание письма по указанному адресу?

uses
....
ShellAPI,
....
procedure TAboutBox.FormCreate(Sender: TObject);
begin
Label1.Cursor := crHandPoint;
Label2.Cursor := crHandPoint;
end;

procedure TAboutBox.Label1Click(Sender: TObject);
begin
ShellExecute(Application.Handle, nil,
'http://www.xxx.com/xxx', nil,nil, SW_SHOWNOACTIVATE);
end;

procedure TAboutBox2.Label2Click(Sender: TObject);
begin
ShellExecute(Application.Handle, nil, 'mailto:xxx@xxx.com',
nil,nil, SW_SHOWNOACTIVATE);
end;

procedure TAboutBox.LabelMouseEnter(Sender: TObject);
begin
with Sender as TLabel do begin
if MouseInControl then Font.Color := clLime
else Font.Color := clRed;
end;
end;

Дополнение прислал Denis V Kravchenko

Fido: 2:4657/25.18
E-mail: denis.k@azovstal.com.ua
http://www.geocities.com/denis_v_kravchenko

Nomadic предлагает сделать еще проще:

uses
ShellApi;

ShellExecute('mailto:writer@coolware.com'); // Вызывается почтовый клиент по умолчанию, новое письмо.

ShellExecute('http://coolware.com'); // Вызывается обозреватель Internet по умолчанию, этот URL.

[000135]


Меню дочерних MDI-форм

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

Так, например, если ваше MDI-меню имеет:
[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за невольный каламбур), они используются только лишь для сортировки),

а меню дочерней MDI-формы имеет:
[Файл] [Редактирование] (и им присвоены значения 1 и 3),

то при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы. Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.

Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.

К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а в случае отсутствия дочерних окон - [Открыть] и [Новое].

Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].

Вы все еще можете использовать код родительской формы в дочерней.

Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после его открытия.

[000168]


Как осуществить задержку, не используя 100% времени CPU?

Я хочу создать серверное приложение (текстовый режим) в Delphi 3pro, ожидающее некоторые данные из последовательного порта. Во время ожидания мне необходимо "усыплять" приложение, дабы дать возможность другим программам полноценно использовать время CPU (простое зацикливание repeat ... until не подходит).

  1. repeat ... until не заблокирует другие процессы вашей системы из-за упреждающей мультизадачности win32, но вы правы - вы загрузите CPU на 100%. В этом случае вы заблокируете текущий процесс, означающий, к примеру, что в текущем приложении не будет происходить перерисовка окна.

  2. вы можете обрабатывать приходящие сообщения в теле вашего цикла, чтобы решить проблемы перерисовки приложения, но загрузка CPU так и останется на уровне 100%. Сделать это можно примерно так:

    repeat
    while PeekMessage(Msg,0,0,0,pm_Remove) do begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
    end;
    until ThereIsSomethingGoingOnOnTheSerialLine;

  3. также вы можете использовать паузу (например, Sleep(100)) перед каждым опросом последовательного порта. Это значительно уменьшает нагрузку на CPU.

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

    function MyWndProc(Wnd: HWnd; Msg,wParam,lParam:Integer): Integer;
    begin
    case Msg of
    wm_SerialLineReceivesData: begin
    ...
    end;
    else Result:=CallWindowProc(OldWndProc,Wnd,Msg,wParam,lParam);
    end;
    end;

    и в вашей главной программе:

    var
    OldWndProc: Pointer;
    begin

    OldWndProc:=
    Pointer(SetWindowLong(GetActiveWindow,gwl_WndProc,
    Integer(@MyWndProc)));
    ...
    SetWindowLong(GetActiveWindow,gwl_WndProc,
    Integer(OldWndProc));
    end.

    [000263]


Мемуары

Ken Henderson, CIS 74763,2305:

Уже в течение некоторого времени для больших и малых проектов я использую Delphi. Я начал развертывать широкоприкладные приложения, созданные в Delphi. 10 различных распределенных точек связываются с центральным хранилищем данных, расположенным на Sun S2000. S2000 имеет четыре процессора, гигабайт памяти и 100 гигабайт DASD, поэтому по мощности его можно отнести к кластеру майнфреймов. На каждой рабочей площадке трудятся 5 человек, что в общей сложности составляет 50 пользователей, которые в режиме прямого доступа пользуются Delphi-приложенями. Новое Delphi-приложение заменило приложение, работающее по сети Novell-LAN и написанное на Clipper. По крайней мере, их поддержка была для нас сущим адом. После поступления на службу я унаследовал все это хозяйство и с тех пор загорелся все изменить. До этого создание приложений на Clipper заняло два года, мы же заменили все клиентами, написанными на Delphi через 3 месяца.

Другое приложение, в процессе перестройки конвертированное в Delphi, обрабатывало транзакции, полученные от цифрового оборудования количеством до 250,000 в день. Данные проходят несколько этапов обработки, прежде чем попасть на хранение в S2000. В нормальной ситуации мы обрабатываем и прокачиваем данные в общей сложности объемом около 64 гигабайт. Первоначально я начал создавать код программы обработки транзакций в С, пользуясь библиотекой Sybase DB-Library. Почти шесть месяцев ушло на кодирование и внедрение. Но с помощью Delphi я переписал этот код всего за один месяц. Более того, теперь не только я смогу обновлять клиентов и поддерживать систему - это сможет сделать кто угодно, поскольку это сделано с помощью Delphi.

Основной коллектив моей группы - аналитики баз данных, а не программисты торговых технологий. Но я не хочу, чтобы они были программистами, мне нужны из аналитические способности. Я перепробовал все среды: PowerBuilder, SQL Windows, Visual Basic, Visual C++, Access, Object Vision, ObjectView, Borland C++, Paradox for Windows и др. Все это можно отнести к одной из двух категорий: это или очень сложно для людей, которые не являются профессиональными программистами, или это очень ограничего или откровенно слабо в тех областях (технологиях), которые используются у нас в корпоративных разработках. Пример. PowerBuilder очень сложен, а Visual Basic очень слаб. Другая крайность - визуальная среда в избытке (Object Vision) или ее почти нет (Visual C++).

Мне было необходимо что-то, с помощью чего можно было бы создавать от DLL до приложений DOS (по существу, язык программирования в Delphi тот же, с помощью которого создавались приложения DOS в Borland Pascal 7), вместе с тем достаточно простой для людей, чьи обязанности заключались в сортировке данных на майнфреймах и т.п.. Разработка хорошей базы данных заявок для PC не такая уж и простая задача. Изготовители мэйнфреймов обычно применяют нестандартное аппаратное обеспечение и изолированные операционные системы. И при работе с ними мне необходима среда, позволяющая разрабатывать клиент-серверные приложения для работы с базами данных на высоком уровне, без необходимости постоянного вникания в детали реализации работы того или иного протокола или железа. Также мне необходим инструмент, позволяющий защитить наши инвестиции в разработке не-DB приложений, или, не дай бог, приложений DOS. Мне нужен инструмент, чьи приложения могли бы быть расширены с помощью другого языка и который бы дал мне полный контроль над Windows. Обобщая все вышесказанное, вывод напрашивается сам собой: Delphi. Он успешно сочетает в себе элегантность объектно-ориентированного языка программирования, производительность и истинно шикарную визуальную среду разработки. И в основе всего этого лежит полнофункциональная система доступа к базам данных - BDE. Это лучшее из того, что я когда-либо использовал. [000347]


Powersoft против Delphi

Несколько недель тому назад я услышал интересную историю. В Канаде есть довольно большой пенсионный фонд с активами что-то около $22 миллиардов долларов. У них имеется группа высокооплачиваемых консультантов PowerBuilder, пытающихся создать умеренно сложную систему. Они уже работали больше шести месяцев, а результатов все не было. Другой консультант, которого я знаю, делающий Paradox под DOS, и, по существу, создающий ту же систему, но работающую с Paradox под DOS, требовал чтобы он и другой сотрудник пели похвалы Delphi и допелись до того, что остальные, сытые этим по горло, решили что настало время устроить состязание двух команд и выявить победителя в противостоянии PB/Delphi. В качестве условия постановили создать реально работающее приложение, доведенное до стадии конечного продукта (проект был не такой уж большой). После окончания срока была готова только Delphi-версия. Проект был завершен в течение недели. PB-программисты (да, их было несколько) не успели даже по истечение месяца. Руководство, видимо решив, что задача, по-видимому, была слишком сильно Delphi-ориентированной, решили изменить спецификацию. Наш герой появился через три дня с новой и улучшенной старой версией. Спустя три недели PB-программисты объявили о том, что разработка подходит к концу и скоро они смогут продемонстрировать бета-версию. Прошла еще неделя, подошло к концу отведенное время и наступила пора демонстрации....

Приложение Delphi было продемонстрировано без сучка и задоринки и свою задачу выполнило в полном объеме. Тем временем группа PB-разработчиков сидела в другом угле комнаты и пыталась лихорадочно исправить ошибки, лезущие изо всех щелей. Наконец они были готовы к демонстрации. Во время демонстрации произошло три GPF-ошибки. Пришли к выводу, что это приложение меньше функционально и менее пригодно, чем приложение Delphi (GPF опустили). Но результаты были замяты, поскольку среди руководства были люди, боявшиеся потерять авторитет в глазах окружающих за ту ошибку при выборе средства, в конце концов спустившее в трубу несколько миллионов долларов, да и все-таки какие-никакие, но накопленные за несколько лет работы с PB знания.

Действительно удивительная история, но невероятная она еще в том, что в группе PB-разработчиков работали еще два высокооплачиваемых консультанта. Разработчик же Delphi-приложений был канцелярским служащим, чей опыт в программировании был ограничен средней школой, курсами программирования и шестимесячной практикой написания WordPerfect-макросов.

Michael Lant [000500]


Delphi 1

FAQ 1, Не-технический

"В чем разница между Delphi и Delphi Client/Server?"

Delphi Client/Server содержит сам Delphi плюс...

  • SQL-драйвера для Oracle, Sybase, MS SQL Server, Informix, и InterBase.
  • Право НЕОГРАНИЧЕННОЙ по количеству установки вышеуказанных драйверов.
  • Local InterBase Server Deployment Kit (комплект развертывания локального сервера InterBase).
  • Team Development Tools - Средства групповой разработки (включается в существующую установку PVCS).
  • Исходный код VCL - Visual Component Library.
  • Visual Query Builder - Визуальный построитель запросов.
"Где мне найти документацию по Delphi VCL и Object Pascal?"

Они включены в электронную справку. Выберите Help|Contents и щелкните по гиперссылке "Object Pascal" или "Visual Component Library".

Также эти темы кратко представлены на документах в формате Adobe Acrobat.

Те, кто предпочитает бумажный вид документации, могут приобрести дополнительный комплект документации Delphi за $35, заказав его по телефону 1-800-331-0877.

"Что мне нужно сделать, чтобы стать бета-тестером будущих версий Delphi?"

Обратитесь к Borland по нижеприведенному адресу, написав, что вы хотите стать бета-тестером Delphi. В письме необходимо указать почему вы хотите стать бета-тестером, какой опыт подобной работы вы имеете, каким аппаратным обеспечением в данный момент вы обладаете и другую, необходимую на ваш взгляд информацию. Адрес для писем:

   Delphi Research and Development
   100 Borland Way
   Scotts Valley, CA 95066
"Будет ли выпущена 32-битная версия Delphi и, если да, когда ее можно ожидать?"

"Да, мы выпустим 32-битную версию Delphi для Windows 95 и Windows NT вскоре после коммерческого выпуска Windows 95."

"Сколько будет стоить 32-битная версия Delphi?"

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

"Будет ли Delphi для OS/2 или Macintosh?"

Borland не анонсировал на этот раз планов по поводу реализации версий Delphi для OS/2 или Mac.

"Входят ли в поставку Delphi утилиты для инсталляции моих приложений?"

Нет, но есть множество представленных на рынке инструментальных средств третьих фирм, включая:

      InstallSHIELD
      from Stirling Technologies Inc.
      (800)374-4353

      Eschalon Setup 1.0g
      from Eschalon Development Inc.
      (604) 945-3198
"Где мне найти список книг о Delphi, изданных не-Borland?"

Для получения такого списка загрузите файл TI2776.ZIP с Compuserve или TechFax (1-800-822-4269).

"Как мне узнать об учебных курсах по Delphi, проводимых в моем регионе?"

Загрузите TI2841.ZIP или с Compuserve, или с TechFax (1-800-822-4269). Данный документ содержит список учебных центров, готовящих Delphi программистов в вашем районе.

"А как мне узнать о существовании группы пользователей Delphi в моем регионе?"

Обратитесь в отдел Borland User Group Relations по телефону (408) 431-1138.

"Что такое TI?"

TI - техническая информация (Technical Information) - документ, описыващий пути решения конкретной проблемы, такой как, например, инсталляция, работа с базами данных или общие вопросы программирования. Документы TI часто обсуждают общие технические вопросы, всегда содержат решение проблемы, специфику возникновения ошибок и могут содержать ссылки на дополнительную литературу. Документы TI могут служить источником информации, если вы ищите решение по конкретной технической проблеме, или быть полезными, если вам необходима общая информация. TI могут быть получены через систему Borland TechFax по телефону 1-(800) 822-4296. Множество документов TI также доступны в режиме онлайн на Compuserve (GO BORLAND), ftp (ftp.borland.com), в Интернет (http://www.borland.com) или на Borland Downloadable Bulletin Board System (408-431-5096). Online-версии TI документов имеют имя TIxxxx.ZIP, где xxxx обозначает порядковый номер документа. Для получения списка всех доступных документов TI, свяжитесь с TechFax и следуйте автоматическим голосовым инструкциям, эта услуга позволит получить вам полный каталог документов Technical Information, доступных от Borland.

"Какая будет цена на обновление до 32-битной версии Delphi?"

Будет установлена специальная, доступная цена на обновление для текущих пользователям Delphi, желающих обновить ее до Delphi32. Пока стоимость не установлена.

Как, с помощью модуля WinCrt, мне напечатать выходные данные моей программы, написанной на Turbo Pascal for Windows (TPW) 1.5?

Загрузите WINCRT.ZIP из секции 2 или WINCRT2.ZIP с Borland BBS (408-431-5096). Скачайте, разархивируйте и замените модуль WinCrt в секции 'uses' на WinCrt2. В вашей программе дополнительно появится меню "Print", позволяющее управлять печатью. За дополнительной информацией обратитесь к файлу README, включенному у ZIP-архив. [000578]


Delphi 1

FAQ 3, установка

"При щелчке на иконке TDW экран становится пустым или наблюдается буйство красок. Как мне исправить это?"

Turbo Debugger video DLL, которую вы используете, очевидно несовместима с вашим видео-драйвером Windows. Загрузите TDSVGA.ZIP из library 2 и попытайтесь заменить TDWGUI.DLL или TDSVGA.DLL. Следуйте за инструкциями файла "readme".

"При выходе из Turbo Debugger for Windows машина зависает. Что мне делать?"

Turbo Debugger video DLL, которую вы используете, очевидно несовместима с вашим видео-драйвером Windows. Загрузите TDSVGA.ZIP из library 2 и попытайтесь заменить TDWGUI.DLL или TDSVGA.DLL. Следуйте за инструкциями файла "readme".

"При щелчке на иконке TDW, я получаю сообщение об ошибке 'Cannot load WINDEBUG.DLL' (не могу загрузить WINDEBUG.DLL). Что мне делать?"

Эта ошибка связана с попыткой использовать отладчик TPW 1.0 под Windows 3.1. TPW 1.0 был создан для работы под Windows 3.0. Есть два решения этой проблемы. Рекомендуемое решение заключается в обновлении до TPW 1.5 или BP 7.0. Для получения информации о ценах и заказе продуктов звоните по телефону (800) 331-0877. Другое решение заключается в повторной установке Windows 3.0.

"Я только что установил Borland C++ 4.x, также у меня есть TPW 1.5 и BP 7.0. Будут ли у меня проблемы с Pascal Turbo Debugger for Windows? Что необходимо для их совместной правильной работы?"

Загрузите TI1736.ZIP.

"Мой VBX не грузится или в момент загрузки "валит" Delphi. В чем дело?"

Наиболее вероятно, что вы пытаетесь использовать VBX, совместимый с Visual Basic 2.0 или 3.0. Delphi может использовать VBX, совместимый только с VB 1.0.

"После установки Delphi несколько VB-приложений перестали работать. Как теперь быть?"

Из файла INSTALL.TXT, расположенного в каталоге ..\DELPHI:

     __________________________________________________________
     |
     |  2. ПРЕЖДЕ ЧЕМ ВЫ ЗАПУСТИТЕ УСТАНОВКУ (SETUP)
     |  -----------------------
     |  .
     |  .
     |  .
     |  o Элементы управления VBX - SETUP устанавливает следующие
     |    файлы VBX в каталог \WINDOWS\SYSTEM и перезаписывает
     |    любые существующие файлы VBX с теми же именами:
     |
     |      GAUGE.VBX
     |      SWITCH.VBX
     |      PICT.VBX
     |      CHART2FX.VBX
     |
     |    Перед установкой проверьте наличие файлов с этими
     |    именами и при необходимости создайте их копии.
     |
     |  .
     |  .
     |  .
     |  _______________________________________________________
Оригинальные файлы, которые, возможно, были перезаписаны, могли быть частью вашего VB-приложения. Если причина в этом, необходимо осуществить следующие шаги (приведен пример для файла GAUGE.VBX):
  1. Загрузите Delphi и удалите GAUGE.VBX из Палитры компонентов:
    1. Выберите пункт меню Options | Install Components.
    2. Выберите GAUGE из списка установленных модулей (Installed Units).
    3. Щелкните на кнопку REMOVE (модуль исчезнет из списка).
    4. Щелкните на кнопку OK. Delphi перекомпилит библиотеку компонентов.
    5. Закройте Delphi.
  2. В File Manager переименуйте файл GAUGE.VBX в файл с именем, например, BIGAUGE.VBX.
  3. Снова загрузите Delphi и добавьте BIGAUGE.VBX в Палитру компонентов:
    1. Выберите пункт меню Options | Install Components.
    2. Щелкните на кнопку VBX.
    3. Выберите необходимый VBX (в нашем случае BIGAUGE.VBX).
    4. Щелкните на кнопку OK с диалоговом окне "Install VBX File".
    5. Щелкните на кнопку OK с диалоговом окне "Install Components". Delphi перекомпилит библиотеку компонентов.
  4. Скопируйте VBX (GAUGE.VBX), используемое вашим VB-приложением, в каталог \Windows\System directory.
Это должно решить проблемы с конфликтами файлов.

"После установки Delphi, каждый раз при запуске приложения компании NetCom NetCruiser (являющегося VB-приложением), возникает надпись 'NETCRUZ An error has occurred in your application. If you choose ignore..' (NETCRUZ: В вашем приложении произошла ошибка. Если вы выберите игнорировать...). Что случилось?"

Delphi установил "GAUGE.VBX" поверх родного VB. Установленный Delphi файл несовместим со своей VB-версией (Смотри выше Q&A).

Я пытаюсь запустить учебник по Delphi, но он ОЧЕНЬ медленный. В чем дело?

Две видимых причины:

  1. Запуск учебника удваивает требования для памяти при работающей Delphi.
  2. Учебник вынужден синхронизировать свои действия с работой IDE, т.к. фактически учебник управляет работой IDE. Отсюда и замедленная работа Delphi, выполняемая самостоятельно гораздо быстрее.
Если вам не нужно создавать приложения с OLE-клиентом, рекомендуем удалить из библиотеки компонентов Delphi компонент TOLEContainer. Инициализация OLE увеличивает время загрузки Delphi почти вдвое и и требует дополнительно около 1Mb памяти.

Для удаления OLE компонента из библиотеки компонентов Delphi воспользуйтесь пунктом меню Options | Install Components и удалите модуль OLEREG из левого ListBox. Щелкните на OK и библиотека компонентов перекомпилится без OLE.

Когда я щелкаю на иконке Delphi, я получаю сообщение "COMPOBJ.DLL caused a GPF at 0003:2EED".

COMPOBJ.DLL - часть подсистемы Windows OLE. Дважды проверьте установку OLE. Достаточно непросто определить проблему: частичная установка OLE, "смесь" версий OLE модулей или испорченный файл OLEREG.DAT. Компонент Delphi TOLEContainer требует/загружает OLE и библиотеку компонентов Delphi (COMPLIB.DCL), где находится компонент TOLEComponent, и которая загружается при запуске Delphi.

Для проверки правильности установки OLE, откройте каталог WINDOWS\SYSTEM и сравните имеющиеся там файлы с нижеприведенной таблицей:

    имя файла       дата     время   версия
    ----------------------------------------
    BOLE16D.DLL     02/15/95 8:00    1.00 *

    OLE2.DLL        09/4/94  8:07    2.02
    OLE2.REG        09/4/94  8:07    2.02
    OLE2CONV.DLL    09/4/94  8:07    2.10
    OLE2DISP.DLL    09/4/94  8:07    2.02
    OLE2NLS.DLL     09/4/94  8:07    2.02
    OLE2PROX.DLL    09/4/94  8:07    2.02
    STDOLE.TBL      09/4/94  8:07    1.10
    COMPOBJ.DLL     10/3/94 13:16    2.02
    STORAGE.DLL     09/4/94  8:07    2.02
    TYPELIB.DLL     09/4/94  8:07    2.02
* Единственная DLL от Borland - все остальные от Microsoft.

Проблема заключается в путанице версий OLE, Borland распространяет Microsoft-овские OLE v2.02, Windows 3.1 устанавливает OLE v2.0. Единственное исключение из вышеприведенного списка - BOLE16D.DLL от Borland.

Если вам не удалось найти и локализовать проблемы конфигурации OLE, вы можете попробовать перекомпилить библиотеку компонентов Delphi без TOLEContainer. Это позволит вам пользоваться Delphi (без поддержки OLE), пока вы не решите ваши проблемы с OLE. Отсутствие инициализации OLE уменьшает время загрузки Delphi почти вдвое и и уменьшает расход памяти примерно на 1Mb.

Для пересоздания библиотеки компонентов Delphi без TOLEContainer, первым шагом выйдите из Delphi. Затем найдите и отредактируйте в каталоге Windows\system файл DELPHI.INI. Найдите строчку:
ComponentLibrary=C:\DELPHI\BIN\COMPLIB.DCL
и замените ее на:
ComponentLibrary=

Сохраните изменения и выйдите из файла DELPHI.INI. Запустите Delphi. Delphi выведет сообщение об ошибке, информирующее о невозможности загрузки библиотеки компонентов. Просто щелкните на кнопке OK. Выберите пункт меню Options | Install Components и задайте новое имя файла в поле "Library filename" (например, c:\delphi\bin\newlib.dcl). Щелкните на кнопке Add, затем на кнопке Browse. Перейдите в каталог Delphi\lib. Выберите STDREG.DCU и нажмите кнопку OK. Повторите операцию (щелкая на кнопку Add) и добавьте следующие *.DCU файлы: VBXREG, STDREG, DBREG, SYSREG, DDEREG, SWITCH, GAUGE, PICT, CHART2FX, SAMPREG и LIBEXPT. Теперь нажмите на кнопку OK, после чего библиотека будет скомпилирована и загружена для вашего использования.

Я пытаюсь запустить Delphi под OS/2 Warp (для Windows) c установленным fixpak. Каждый раз, при попытке закрыть сгенерированное приложение, я получаю GPF в TOOLHELP.DLL по адресу 0001:0626. Эта ошибка сопровождает также все демонстрационные программы. Также существует проблемы выхода из Delphi. При этом я получаю три сообщения: 1) Debug process running... (Идет процесс отладки); 2) Terminating an app the usual way is better... (Завершение приложения обычно лучшее решение...); и 3) Unable to kill the process (Не могу убить процесс). Эти три сообщения возникают при потытке выйти из Delphi. Единственный выход - убить его в списке задач. Кто-нибудь наблюдал эту ошибку под Warp?

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

Fixpack, прежде чем обновить систему, требует создания архивной директории. Там сохраняются несколько упакованных файлов. Распаковать их можно из простой командной строки. Выполните команду "unpack users.sc_" для каждого файла и убедитесь в том, что они распакованы в нужной директории.

USERS.SCR и WINSMSG.DLL должны размещаться в директории system операционной системы. WINOS2.COM размещается в директории windows (родительской для System).

Предупреждение: Данная технология не была одобрена IBM.

Я пытаюсь запустить Delphi под OS/2 2.1X и сталкиваюсь с теми же проблемами, что и в предыдущем вопросе.

Delphi был протестирован только под Warp, и под версией OS/2 корректно не работает.

Существует ли какая-нибудь полезная хитрость навигации по IDE?

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

Как мне развернуть мое приложение на других машинах?

Почитайте DEPLOY.TXT (расположен в директории Delphi), там содержатся все инструкции на этот счет.

Когда я запускаю свое приложение на другой машине, я получаю ошибку "error initializing IDAPI $2108" (ошибка инициализации IDAPI) или что-типа этого. Как избежать этого?

Если ваше приложение работает с базой данный, вам необходимо установить IDAPI на той машине, где вы собираетесь его запустить. Почитайте DEPLOY.TXT (расположен в директории Delphi), там содержатся все инструкции на этот счет. Если IDAPI уже установлен, убедитесь в наличие пути к IDAPI-каталогу в переменной DOS PATH и в секции [IDAPI] файла Windows WIN.INI, а также в их корректности.

Существует ли список книг по Delphi?

Да. Загрузите TI2776.ZIP из Library 2 Compuserve Delphi forum или закажите через TechFax по телефону 1-800-822-4269.

Я думаю о покупке Delphi. Где я могу найди дополнительную информацию?

Загрузите файлы TI2767.ZIP и TI2768.ZIP из Library 2 этого форума.

При щелчке на иконке 'Database Desktop' или 'Database Engine Configuration' я получаю сообщение об ошибке "multiple net files found". Как мне решить это?

Найдите в системной директории файлы *.lck и удалите их.

Как мне активизировать контроль версий (Version Control) в Delphi?

Перейдите в меню Help | Topic Search, нажмите пункт 'Version control' и следуйте инструкциям. Данные возможности доступны только в версии Client/Server.

Я получаю сообщение об ошибке "Out of Memory" или "Out of System Resources", хотя доступной памяти у меня более чем достаточно! Что это может быть?

Попробуйте сменить видеодрайвер на стандартный VGA драйвер Windows (vanilla- flavored). Для изменения видеодрайвера щелкните на иконке Windows Setup и выберите Options | Change System Settings. Если после этого сообщения о системных ошибках ушли в прошлое, значит дело было в вашем видеодрайвере. Обратитесь к изготовителю вашего видеодрайвера для получения самой последней версии. Причина такого странного поведения в том, что при создании окна методом Create вместо его дескриптора почему-то возвращается код ошибки.

У меня уже есть Paradox for Windows и dBase for Windows. Delphi-версия Borland Database Engine сможет сосуществовать с этими продуктами?

Да, новая Delphi-версия Borland Database Engine (также известная под именем IDAPI) была сертифицирована для Paradox for Windows и dBase for Windows.

Всегда устанавливайте Delphi-версию IDAPI и SQL Links поверх имеющихся в вашей системе, т.к. вместе с Delphi в комплекте идет самая последняя версия описываемого продукта.

Я предполагаю что нашел ошибку в продукте, как мне сообщить об этом?

Загрузите TI1171.ZIP и следуйте приведенным инструкциям.

Где мне найти Language Reference Guide (руководство по языку) для Delphi?

Language Reference Guide доступен отдельно. Позвоните в Order Desk по телефону 800-331-0877 и справьтесь о цене.

Я использую Warp и имею проблемы при работе с Acrobat. Какие идеи?

Перейдите в настройки сессии Acrobat Win-OS/2 и установите Win ATM в 'ON'. То же самое можно сделать и в настройках самих Win-OS/2 (в папке системных установок).

При попытке запустить Delphi я получаю сообщение об ошибке "can't open c:\delphi\bin\complib.dcl". Как мне исправить это?

Эта ошибка может произойти по разным причинам: share или vshare не загружена, для share использованы неверные параметры (должно быть F:4096 L:40). Секция IDAPI файла WIN.INI неверна или отсутствует. Она должно выглядеть примерно так:

    [IDAPI]
    CONFIGFIL01=C:\IDAPI\IDAPI.CFG
    DLLPATH=C:\IDAPI
COMPLIB.DCL может быть испорчен. Сделайте новую копию с CD ..\RUNIMAGE\DELPHI\BIN\COMPLIB.DCL

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

    C:\WINDOWS\SYSTEM\COMPOBJ.DLL   108,544
    C:\WINDOWS\SYSTEM\OLE2.DLL      302,592
    C:\WINDOWS\SYSTEM\STORAGE.DLL   157,696
    C:\DELPHI\BIN\COMPLIB.DCL       1,058,784
При несовпадении размера обновите их с CD.

Если все еще ошибка присутствует, возможно "криво" установлен Windows. Вот что еще можно проверить:

    VER.DLL     9,008
    USER.EXE    264,016
    KRNL386.EXE 76,400
Adobe Acrobat выдает сообщение "Could not find Adobe Type Manager" при попытке просмотреть поставляемую в этом формате документацию по Delphi. Я работаю под Win NT. Как мне решить эту проблему?

Загрузите Acrobat Reader версию 2.1. Данная версия работает под NT и поддерживает более широкий диапазон принтеров. Вы можете ее найти в форуме Adobe Applications на Compuserve (GO ADOBEAPP).

Можно также попробовать решить проблему добавлением следующей строки:

    ATMOption=1
в секцию [Abode Viewer] файла ACROREAD.INI. Затем скопируйте его в ACROEXCH.INI (оба файла должны располагаться в каталоге \winnt35). Если у вас нет ACROEXCH.INI, сделайте копию acroread.ini с именем acroexch.ini. При этом могут наблюдаться проблемы со шрифтами, но Acrobat будет работать.

Я пишу MDI-приложение с помощью Delphi. Когда я сворачиваю дочернее MDI-окно, возникает GPF. Вам известно об этой проблеме?

Да, это известная проблема, решаемая выпущенной заплаткой. Загрузите заплатку (delpatch.zip), запустите ее и пересоберите библиотеку.

Почему при запуске интерактивного учебника я получаю сообщение "To run the interactive tutors, you must change the Delphi configuration slightly..." ("Для запуска интерактивного учебника, вы должны немного изменить конфигурацию Delphi...")?

Это случается, когда текущие настройки Delphi отличаются от настроек, заданных по умолчанию. Сохраните ваш текущий файл DELPHI.INI в директории Windows и скопируйте DELPHI.CBT в файл DELPHI.INI. После этого учебники будут работать правильно. После завершения сеанса обучения старый DELPHI.INI должен быть восстановлен.

Интерактивные учебники работают некорректно. Как мне заставить их нормально работать?

Смотри предыдущий ответ.

При попытке запуска интерактивного учебника я получаю сообщение "Error creating Process: Insufficient memory to run the interactive tutors." ("Ошибка создания процесса: Для запуска интерактивного учебника недостаточно памяти."). Как мне решить эту проблему?

Интерактивные учебники имеют бОльшие требования к памяти, чем сама Delphi, примерно вдвое. Поэтому убедитесь в наличии достаточного количества памяти перед запуском учебника. 12 или 16 мегабайт вполне достаточно, однако убедитесь, что Windows запущена в 386-м расширенном режиме (Enhanced mode) и файл подкачки имеет достаточный размер. Если вы считаете, что имеете достаточное количество RAM, но ошибка присутствует, попробуйте увеличить размер файла подкачки в пункте Virtual Memory меню 386 Enhanced Панели Управления. Windows постоянно что-то откачивает на диск, поэтому учебнику по Delphi этого файла в какой-то момент может оказаться мало, что и вызывает упомянутую ошибку. Наконец, осуществите "чистую" загрузку Dos и Windows, дабы исключить возможный захват памяти другими процессами, но если и после этого учебники не грузятся, значит у вас проблемы с памятью. Загрузите TI 1561 и TI 1283 с Compuserve (TI1561.ZIP, TI1283.ZIP) или TechFax (1-800-822-4269) для получения детальных инструкций по "голой загрузке" вашей машины.

Я случайно удалил группу Delphi и все ее иконки. Как мне восстановить это?

Существует программа для создания Программной группы Delphi и связанных с ней иконок. Ее имя DLPGRP.ZIP. Вы можете найти ее в секции "From Borland" форума "Borland Delphi".

Для чего используется W8LOSS.EXE?

W8LOSS.EXE - инструмент командной строки, оптимизирующий размер вашего EXE-Файла и времени его загрузки. Он является эквивалентом опции OPTIONS|PROJECT|LINKER и включателя 'optimize for size and load time. (оптимизировать размер и время загрузки)'. Используйте этот инструмент, если вы испытываете трудности при работе с описанными опциями в IDE.

Я произвел ручную установку Delphi, что мне необходимо добавить в WIN.INI и какие пути прописать для того, чтобы Delphi работала корректно? (Предположим я установил на C:)

Добавьте "C:\iblocal\bin;c:\delphi\bin" к путям (path) вашего autoexec.bat.
Добавьте следующие строки в ваш WIN.INI:

    [IDAPI]
    DLLPATH=C:\IDAPI
    CONFIGFILE01=C:\IDAPI\IDAPI.CFG

    [Borland Language Drivers]
    LDPath=C:\IDAPI\LANGDRV

    [BWCC]
    BitmapLibrary=BWCC.DLL

    [Interbase]
    RootDirectory=C:\IBLOCAL

    [Paradox Engine]
    UserName=PxEngine
    NetNamePath=C:\
    MaxTables=64
    RecBufs=64
    MaxLocks=64
    MaxFiles=64
    SwapSize=64

    [DDE Servers]
    DBD=C:\DBD\DBD

    [DBD]
    WORKDIR=C:\DBD
    PRIVDIR=C:\DBD\DBDPRIV
Я работаю под OS/2 Warp (без fixpak) и не могу запустить в Delphi форму по умолчанию без тотального зависания системы. Мышь не отвечает, все прерывания OS/2 недоступны, на ctrl-alt-delete ноль реакции.

Попробуйте выключить опцию "ROM-Shadowing" в вашем BIOS.

Программа Install для Delphi не запускается. Выдает ошибку: "Cannot execute INSTALL.EXE or one of it's components. (Не могу запустить INSTALL.EXE или один из этих компонентов)"

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

Прежде всего необходимо проверить эту ошибку при чистой загрузке системы, дабы исключить возможность конфликта памяти с другой программой. Если это не помогает, проверьте присутствие и корректность переменной TEMP, и наличие достаточного места на диске. (примерно 10-15 мегабайт.) Помните о том, что Delphi устанавливает некоторые свои DLL в каталоге WINDOWS\SYSTEM, поэтому важно наличие свободных 10 мегабайт на диске, на котором установлена Windows.

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

Можно попробовать заменить устанавливаемые файлы вручную. Скопируйте INSTXTRA.PAK, INSTRUN.EX_, BAMGR16.DL_ и INSTALL.INI во временную директорию.
Распакуйте файлы *.??_ с помощью EXPAND.EXE.
Запустите INSTRUN.EXE с INSTALL.INI в качестве параметра.

Руководство содержит описание последнего способа установить Delphi. Но это осуществимо только в случае наличия у вас CD. Способ заключается в копировании директории runimage на ваш жесткий диск, ручном создании програмных груп и ручной настройке INI-файлов.(Смотри предыдущий В/О).

Я без проблем установил Delphi, и при двойном щелчке на иконке Delphi программа начинает загружаться, но практически перед самым окончанием загрузки появляется мигающее диалоговое окошко и программа "схлопывается", возвращая меня в Program Manager. Или же демонстрируется некоторое время окно заставки, после чего оно исчезает, не загружая Delphi (без каких-либо сообщений или предупреждений). В чем может быть дело, какие идеи?

Попробуйте заменить видеодрайвер на стандартный VGA с помощью утилиты Windows Setup (группа Main). Если это решило проблему, необходимо обратиться к производителю видеокарты для получения последней версии драйвера (большинство производителей видеокарт уже обновили драйверы для работы в Delphi). Если это не работает, попробуйте удалить delphi.ini из директории Windows и перезагрузить Delphi (delphi.ini будет пересоздан). Если и это не помогает, попробуйте сохранить C:\DELPHI\BIN\DELPHI.EXE и скопировать свежий DELPHI.EXE с CD-ROM (\RUNIMAGE\DELPHI\BIN\DELPHI.EXE), может быть ваш EXE-файл оказался испорченным. Если опять проблема не решена, значит имеет место быть конфликт с вашей текущей системной конфигурацией. Для решения проблемы в этом случае вам необходимо убедиться, что система стартовала абсолютно "голой" или в минимальной конфигурации, и попробовать запустить Delphi. Загрузите TI 1561 и TI 1283 с Compuserve (TI1561.ZIP, TI1283.ZIP) или TechFax (1-800-822-4269) для получения детальных инструкций по "голой загрузке" вашей машины.

Я пытаюсь установить vbx или компонент в библиотеку компонентов, используя пункт меню Options | Install Components... После добавления компонента я нажимаю в диалоговом окне Install Components 'Ok', закрываю диалог, после чего библиотека компонентов сама пересобирается (как и положено). Но после этого новый компонент в палитре компонентов не появляется! При установке компонента ошибок не возникало. Что я делал неправильно?

Закройте Delphi и проверьте с помощью File Manager или команды DOS 'attrib' атрибуты complib*.*. Иногда файлы complib.dcl и complib.~dc становятся пригодными только для чтения. Убедитесь, что они НЕ имеют флага read-only. Если complib.dcl имеет флаг только для чтения, то библиотека компонентов не в состоянии сохранить любые изменения, которые вы сделали, например, установка или удаление компонента. Менее очевидная, но аналогичная ситуация возникает когда файл complib.~dc также годен только для чтения. Данный файл является backup-файлом для complib.dcl. При пересоздании, библиотека компонентов сохраняет свою текущую версию, файл complib.dcl, в файле complib.~dc. Но если этот файл имеет флаг read-only, complib.dcl не в силах сохранить копию complib.dcl, и поэтому библиотека типов не пытается осуществить свое изменение. Поэтому в первую очередь необходимо убедиться в том, что файлы complib.dcl и complib.~dc пригодны не только для чтения, но и для записи.

Я пытаюсь установить новый компонент или VBX в мою библиотеку компонентов, и после выбора компонента или VBX в диалоговом окне Options | Install Components я нажимаю "OK" для возврата в Delphi, но при пересоздании библиотеки компонентов я получаю сообщение об ошибке "File not found [filename.dcu]" (файл [filename.dcu] не найден). Файл находится на моем жестком диске и поле редактирования 'Search Path' в диалоговом окне Install Components содержит правильный путь. Почему Delphi видит компонент во время его добавления, а во время пересоздания библиотеки не видит?

Попробуйте проверить длину пути поиска в поле редактирования диалогового окна Install Components. Этот феномен может объясняться только очень длинным путем; Delphi выбитает только первые 127 символов пути поиска. Так, если ваш путь содержит больше, чем 127 символов, и вы к его концу добавляете еще один путь для поиска вновь устанавливаемой компоненты, то при пересоздании библиотеки компонентов найти его она не сможет. Попробуйте перенести новый путь немного "поглубже", т.е. поближе к его началу и повторить операцию установки компонента заново. Если это сработает, вам необходимо укоротить имеющиеся пути или переместить имеющиеся каталоги на один или несколько уровней ближе к корню.

Я произвел установку с CD, но получаю сообщения об испорченных файлах. Что-то случилось с CD?

В действительности очень маловероятно, что носитель (CD) испорчен. Обычно порча файлов может происходить при их копировании. Чаще всего это происходит на быстрых компьютерах (главным образом на DX4 и P5), имеющих быстрый диск.

Попробуйте тормознуть компьютер. Легче всего это сделать с помощью кнопки Turbo (не вы одни удивляетесь, что данная кнопка нужна для каких бы то ни было задач). Если ваш компьютер не имеет кнопки Turbo, попробуйте выключить в BIOS затенение видеопамяти, выключить Smartdrive, убрать кэширование Windows или скомбинировать все вышеперечисленное.

Если и после этого проблема не исчезла, скопируйте с CD директорию установки на ваш жесткий диск (при "тормознутом" компьютере) и попробуйте произвести установку с него.

При установке Delphi я получаю сообщение об ошибке: "No ExtVer Method" в файле ODBCDRV.PAK ..\install\disk3. Что это за метод?

Это известная ошибка. Тем не менее попытайтесь сделать следующее:

  1. Осуществите "голую" загрузку.(TI 1561)
  2. Установите инсталляционный диск. Скопируйте подкаталог INSTALL из Delphi CD во временную директорию жесткого диска и запустите оттуда SETUP.EXE.
  3. Попытайтесь запустить Delphi с CD ROM (ti 2777) и, если это работает, скопируйте директорию Runimage на жесткий диск.
Кроме того, эта ошибка может возникнуть, если вы произвели установку Delphi без установки DBD и/или Local Interbase.

Для установки своего приложения я инсталлировал BDE, после чего получил следующее сообщение об ошибке: "Could not find language driver" (не могу найти драйвер языка). В чем дело?

Программа установки не устанавливает драйвер языка, если вы устанавливаете BDE с _сетевого_ диска. Вам необходимо вручную распаковать LANGDRV.PAK, используя UNPAQ.EXE, в каталог IDAPI\LANGDRV (Вам необходимо вручную создать подкаталог LANGDRV)

Мой FormExpert не запускается или не появляется. Что мне нужно сделать?

  1. Убедитесь, что в секции [Experts] в delphi.ini имеется строка FormExpert=Mydrive:\delphi\bin\exptdemo.dll
  2. Закройте Delphi, сохраните DELPHI.INI, удалите DELPHI.INI, снова запустите Delphi и FormExpert.
  3. Сохраните EXPTDEMO.DLL и скопируйте его новую копию с Delphi CD ROM из подкаталога Runimage.
[000579]


Delphi 1

FAQ 4, IDE

  1. Где мне получить дополнительную информацию о Delphi?

    Теперь доступны для скачивания из библиотеки "From Borland" следующие инфорационные файлы о Delphi:

         DELBKS.TXT   -=> Delphi BookList (список книг о Delphi)
     DEL_FS.ZIP     -=> Delphi Fact Sheet (страница фактов)
     DEL_ QI.ZIP      -=> Delphi  Quick Info Sheet (страница краткой информации)
  2. Как мне привязать кнопку к нижней границе окна так, чтобы при изменении их размеров расстояние между ней и нижней границей окна не изменялось?

    Создайте TPanel, установите свойство alignment в bottom и расположите на ней вашу кнопку. Если вы не хотите, чтобы панель была видимой на форме, сбросьте флаг ctl3d, установите bevels в none и parentcolor = true.

  3. Как мне добавить "Help Break" в главное меню с выравниванием по правому краю?

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

    Help1.Caption := #8 + Help1.Caption;

    Примечание: С недавних пор это не рекомендуется Microsoft, а в Windows 95 не работает вовсе.

  4. Что мне нужно прочесть/купить, чтобы узнать о скрытых "методах"?

    Электронная справка по теме создания компонентов (Component Writer's Help) содержит более глубокие сведения, кроме того, вы можете купить исходный код VCL и изучить это "в подлиннике".

  5. Как мне грамотно осуществить выравнивание чисел с десятичной точкой?
            0.50
       10.55
      245.98
    В объекте TEdit включите возможность редактирования нескольких строк и установите стиль равным es_Right. В случае TDBEdits, вы можете добавить поля к вашей форме и задать соответствующие значения свойствам Alignment и DisplayFormat.

  6. Как мне задать порядок обхода элементов управления клавишей Tab?

    Выберите на форме необходимые компоненты и воспользуйтесь пунктом меню Edit | Tab Order.

  7. Как мне убедить Windows, что программа, написанная в VB, является хранителем экрана?

    1. Поместите следующую строчку в исходном коде проекта (Project Source):
      {$D SCRNS AVE:NameOfScreenSaver}

    2. Скомпилите проект
    3. Переименуйте .EXE в .SCR и поместите в каталог Windows.

    Для корректной работы хранителя экрана необходимо в обработчиках событий OnClick и OnKeyUp вызывать метод Close. В ответ на событие OnMouseMove необходимо осуществить проверку, и, если оно возникло НЕ первый раз, необходимо также вызвать метод Close.

    CONST FirstTime : Boolean = True;
    begin
    IF NOT FirstTime THEN Close;

  8. Как мне обойти ошибку Stream Read Error?

    Попробуйте удалить *.DSM-файл и перекомпилить ваш проект.

  9. Возможно ли создание глобальных переменных в Delphi?

    Откройте новый модуль и объявите необходимые вам глобальные структуры в секции interface (секция implementation должна оставаться пустой). Добавьте имя данного модуля в список USES тех модулей, для которых необходимо получить доступ к объявленным глобальным переменным.

  10. Почему при закрытии окна модуля (pas) также закрывается и окно с формой?

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

  11. Когда я компилю код с использованием модуля WinPrn, Delphi говорит, что не может найти WinPrn.DCU.

    Добавьте \DELPHI\SOURCE\RTL70 к путям поиска вашего проекта.

  12. Как мне разместить форму в центре экрана?

    Используйте вместо оператора "/" оператор "div":

    MyLeft := (Screen.Left - Form1.Left) div 2;

    Или присвойте свойству Position вашей формы значение poScreenCenter.

  13. Если я компилирую мой BP7-проект в Delphi, могу ли я использовать с ним интегрированный отладчик? Если так, то как мне указать Delphi, какой файл у меня является первичным? А если у меня нет ни одной формы?

    Да, вы можете воспользоваться встроенным дебаггером. Первичный файл - файл с расширением *.PAS, который вы открывали как проект. Выберите "Open Project", измените тип файла с *.DPR на *.PAS и затем выберите программу BP7, которую вы хотите компилить.

  14. Как при добавлении новых элементов (listBoxName.items.add('xxx')), делать их видимыми? Поясняю: если общее число элементов превышает их видимое количество, появляется полоса прокрутки, и новые пункты добавляются в нижнюю, невидимую часть списка. Я хотел бы перемещать список "наверх", чтобы был виден самый последний, нижний пункт.

    Попробуйте установить:

    listBoxName.items.add('xxx')
    listBoxName.itemIndex := (listBoxName.items.count-1)

  15. Существует у компонента ListBox свойство, позволяющее выровнять текст по правому краю?

    Нет. Попробуйте заполнить строку пробелами.

  16. Что обозначает сообщение отладчика "Debugger Is Unable To Stop Due To 'Hard Mode'"? (отладчик не в состоянии остановиться из-за Hard Mode - дословно "Тяжелый Режим").

    ОПРЕДЕЛЕНИЕ: Hard mode - это такое состояние Windows, когда невозможна никакая обработка сообщений. Это происходит при отрисовке меню и некоторых операциях ядра. Это означает такое состояние, когда Delphi не может "заморозить" ваше приложение, не блокируя Windows. Обычно это возникает при большом числе вызовов SendMessage. Как можно выйти из режима Hard mode: необходимо сильно "встряхнуть", ударить систему. Например, вполне достаточно вывести системное модальное окно, сообщающее о текущем режиме Hard mode! Коротко: установите дополнительную точку останова на строке *перед* той, которая сообщает системе о переходе в режим Hard. Вызов системного модального диалога обычно заставляет систему выйти из этого режима, после чего вторая точка останова сработает как обычно. Изложенный способ носит название "Маневр Мебиуса".
    Примечание: Поскольку отладчик управляется сообщениями, он не может позволить вам остановить его в точке останова, если он думает что система находится в Hard mode, и если вы не предпримете в этой ситуации попытки выйти из Hard mode, система может зависнуть.

  17. Возможно ли загрузить BP-программу (или как проект, или как программу) в IDE и скомпилить ее?

    Да, возможно, но необходима небольшая квалифицированная подсказка. Если быть более точным, в Delphi можно загрузить BPW-программу. Выберите пункт меню Open Project или соответствующую кнопку на панели управления и в выпадающем списке типов файлов выберите *.PAS files. Это позволит загрузить BPW *.PAS-программы. Не забудьте добавить \DELPHI\SOURCE\RTL70 в пути поиска вашего проекта.

  18. Почему простейшие EXE-файлы имеют такой большой размер (одна форма с одной кнопкой 200K)?

    Delphi VCL основаны на RTTI и исключениях. Это уже "отбирает" примерно 120Kb от 'пустого' приложения. 200K вы получаете за счет добавочной информации или неоптимизированного компилятором кода. Обратите внимание на тот факт, что при добавлении второй кнопки размер вашего EXE-файла будет не 400K, а всего навсего 201K, т.е. после необходимого кода располагаются "обычные данные/код" с типичными (ожидаемыми) размерами. Вы можете немного уменьшить размер EXE, отмечая пукнт "Optimize For Size And Load Time" на странице "Linker" в диалоге OPTIONS|PROJECT.

  19. Могу ли я воспользоваться вторым монитором для контроля выходных данных BP-программы?

    Для использования двух мониторов необходимо, чтобы один из них был MDА-монитором (старый черно-белый стиль Hercules), а другой монитором стандарта VGA (или EGA, и т.п.). Они должны использовать два адресных пространства: $B000 для MDA и $B800 для VGA. После установки обоих мониторов можно сообщить BP IDE о наличии второго монитора в Options/Environment/StartUp. Монитор по умолчанию, стартующий BP IDE, будет отображать поток выходных данных программы.
    ПРИМЕЧАНИЕ: после установки карты Hercules, ваша VGA карта будет доступна только как 8-битная. DELPHI данную характеристику не поддерживает.

  20. Каким способом можно сообщить активному дочернему MDI окну о том, что была нажата кнопка "Сохранить" на панели управления родительского окна? Вызов TEditForm.Save1click не работает.

    Попробуйте:

    with  Application.MainForm. ActiveMDIChild as TEditForm do
    Save1Click(Sender);

    Или это:

    if  ActiveMDIChild is TEditForm do
    TEditForm( ActiveMDIChild).Save1Click(Sender);

  21. Почему, если в компоненте ComboBox свойству 'Style' присвоить значение 'csDropDownList', то следующая строка ничего не делает?

    combobox1.text := 'Здесь происходит что-то странное!';

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

    combobox1.ItemIndex:=0;
    {предположим combobox1.Item[0] = 'Здесь происходит что-то странное!'}

  22. Поле редактирования автоматически отрабатывает CTRL-C, CTRL-X, CTRL-Y и CTRL-Z соответственно для копирования, вырезания, вставки и отката. Как мне показать эти опции в главном меню и, самое главное, связать с надлежащими действиями?

    Попробуйте следующие обработчики событий:

    procedure
    TStaffSearch.SpeedButtonCutToClipBoardClick(Sender: TObject);
    begin if ((  ActiveControl ) is TCustomEdit ) then
    TEdit( ActiveControl).CutToClipBoard; end;
    procedure TStaffSearch.Delete1Click(Sender: TObject);
    begin if (( ActiveControl ) is TCustomEdit ) then
    TEdit( ActiveControl).ClearSelection; end;

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

  23. Какую информацию показывает Инспектор Объектов?

    Инспектор Объектов (Object Inspector) отображает все опубликованные (published) свойства класса/объекта, и служит как для просмотра значений свойств, так и для их изменения. Инспектор Объектов не показывает методы класса.

  24. В чем разница между "SetKey / GoToKey" и "FindKey"? Как определить, когда следует использовать одно вместо другого?

    Функционально разницы нет никакой. SetKey + некоторые возможности для работы с IndexFields + GotoKey эквивалентен простому FindKey. Если IndexFields для вас чрезвычайно сложен, программируйте с помощью последовательности SetKey.

  25. Если какой-нибудь способ узнать о свойстве кнопок TDBNavigator (enabled/disabled)?

    Попробуйте:

    type
    TDBNavCracker = class(TDBnavigator);
    ...
    if TDBNavCracker(DBNavigator1).Buttons[nbEdit].Enabled
    then...;

  26. Могу ли я использовать более старые версии SQL Links с теми ID API, которые входят в поставку Delphi?

    Нет, для старых SQL links вы найдете обновления в редакции Delphi Client/Server, или можете получить это отдельно: Delphi + новые SQL Links.

  27. Как в Delphi осуществить обработку ошибок времени выполнения?

    При возникновении ошибки времени выполнения, Delphi генерирует исключение (или, правильнее сказать, создает объект исключительной ситуации). Если отмечена соответствующая опция в настройках среды, исключения будут перехватываться во время выполнения программы из-под Delphi, и Delphi будет перемещать курсор к строке, вызвавшей исключительную ситуацию. Тем не менее, программа при этом не завершает свою работу. Напротив, при возникновении исключительной ситуации программа не сможет окончить свою работу в автоматической режиме, что связано с возможностью поработать с программой в "предсмертном" режиме и найти источник ошибки.

  28. Как храняться в Delphi код/формы?

    Формы храняться в файлах DFM (в бинарном виде), но если вы откроете его (FILE|OPEN FILE) в редакторе IDE как текст, то сможете редактировать его непосредственно.

  29. Может ли TMediaPlayer в Delphi проигрывать avi-файлы?

    Delphi умеет воспроизводить с помощью TMediaPlayer avi-файлы, необходимо всего лишь установить тип файла, его имя, разместить компонент на TPanel и использовать метод open. Для воспроизведения AVI-файлов необходима обновленная версия "Video for Windows", установленная в вашей системе. При выполнении этих условий воспроизведение файлов AVI будет столь же легким, как и воспроизведение файлов WAV. Присвойте типу устройства AutoSelect, поместите компонент на панельку, задайте имя AVI-файла и воспроизведите его. Анимация появится в отдельном небольшом окошке.

  30. Как сделать так, чтобы при вводе пароля в поле редактирования присутствовал эффект 'No Echo'?

    Вам необходимо определить, какой символ (например, *) необходимо отображать при вводе пароля, и назначить его свойству Password в компоненте TEdit. Если вам не нужны символы при вводе, используйте символ пробела, #32.

[000581]


Delphi 1

FAQ 5 VCL (1 из 2)

"Каким образом VCL компоненты могут быть созданы "на лету", во время выполнения программы?"

Следующий код создает модальную форму для ввода пароля во время выполнения программы. Тип TPasswordForm является классом-наследником от TForm, определяемым или в текущем, или в отдельном модуле со ссылкой на него в списке uses.

with TPasswordForm.Create(Application) do
begin                                { например, TForm1, TPasswordForm и пр.. }
ShowModal;                        { Отображаем форму как модальное окно }
Free;                             { Освобождаем форму при закрытии }
end;

Для добавления компонента на форму во время выполнения программы необходимо выполнить несколько шагов:

  1. Объявите переменную экземпляра компонентного типа, который вы хотите создать {например, TButton }. Примечание: переменные экземпляра используются для указания на фактический экземпляр объекта. Сами они объектами не являются.
  2. Испрользуйте конструктор компонента Create для создания экземпляра объекта компонента и его назначения переменной экземпляра, объявленной в шаге 1. Конструктору Create любого компонента в качестве параметра необходимо передать ссылку на его владельца. За редким исключением в качестве параметра owner конструктора Create необходимо указывать форму.
  3. Назначьте "родителя" свойству компонента Parent (например, Form1, Panel1 и пр.). Родитель определяет где должен быть отображен компонент и осуществляет привязку его левого верхнего угла относительно его координат. Для того, чтобы поместить компонент в Groupbox, установите его свойство Parent в Groupbox. Чтобы компонент был видим, ему необходимо иметь родителя, это позволит ему быть отображенным в его области.
  4. Установите любые другие необходимые свойства (например, Width, Height).
  5. Наконец, заставьте компонент появиться на форме, сделав его видимым, т.е. установив его свойсто Visible в True.
  6. Если вы создали компонент и задали ему владельца (свойство owner), вам нет необходимости уничтожать компонент самим, это сделает за вас его владелец в момент его уничтожения. Если же при создании компонента владелец ему присвоен не был, то вся ответственность за уничтожение ложится на вас, его нужно освободить когда он больше вам не нужен. Следующий код показывает процесс добавления компонента TButton на текущую форму во время работы программы:

    var
    TempButton : TButton;  { Это только указатель на TButton }
    begin
    TempButton := TButton.Create(Self);       { Назначаем владельца форму }
    TempButton.Parent := Self;                { Должны назначить Parent (родителя) }
    TempButton.Caption := 'Время выполнения'; { Устанавливаем здесь свойства }
    TempButton.Visible := True;               { Показываем кнопку }
    end;

Поскольку кнопка была создана владельцем, то она будет освобождена автоматически при освобождении владельца (формы).

"Как определить класс компонента, при щелчке на котором появляется контекстное меню?

Используйте свойство PopupComponent компонента PopupMenu для определения компонента, на котором была нажата правая клавиша мыши.

procedure TForm1.PopupItem1Click(Sender: TObject);
begin
Label1.Caption := PopupMenu1.PopupComponent.ClassName;
end;

Можно использовать свойство формы ActiveControl, но компонент, вызвавший контекстное меню, не обязательно может быть активным элементом управления.

"Какие ограничения у стандартных элементов управления Delphi?"

Любой компонент, использующий TList, может хранить информацию размером до 16368 элементов. Для примера, TTabControl может содержать вплоть до 16368 закладок, а палитра компонентов Delphi до 16368 страниц палитры.

Многие стандартные компоненты Delphi являются оболочками стандартных элементов управления Windows. Windows 3.1 накладывают собственные ограничения на данные компоненты. Для примера: TComboBox и TListbox могут содержать до 5440 элементов, в TMemo или TEdit (и др. соответствующие компоненты) до 32кб текста.

Объем ресурсов Windows 3.1 ограничивает компонент TNoteBook и позволяет ему иметь максимум 570 страниц. (Также трудно получить более чем 500 оконных дескрипторов любому приложению Windows.)

Примечание 1: Превышение лимита возбуждает исключение или может сделать работу Windows неустойчивой.

Примечание 2: Многие ограничения, присущие 16-битной версии Windows существенно уменьшены в Windows NT и Windows 95. В будущих 32-битных версих Delphi эти ограничения практически исчезнут.

"Как мне определить длину строки в пикселах с определенным шрифтом?"

Для определения высоты и ширины строки в пикселах могут применяться два метода Canvas - TextHeigh и TextWidth. Не забудьте назначить шрифт объекту Canvas перед тем, как что-либо нарисовать или провести измерения.

Все визуальные компоненты имеют свойство Canvas, но по умолчанию оно защищено (protected) для того, чтобы доступ к нему имели только прямые потомки. Но, поскольку вы создаете свой код на основе наследников TForm, то у вас практически всегда имеется доступ к унаследованному свойству формы Canvas. Компонент TPaintBox имеет доступное (public) свойство Canvas для того, чтобы в обработчике события компонента OnPaint вы могли бы что-либо нарисовать, но можно им воспользоваться и для наших целей.

Если компонент не имеет свойство Canvas, то следующая функция поможет возвратить вам ширину текста, основанного на определенном шрифте:

function GetTextWidth(CanvasOwner: TForm; Text : String;
TextFont :  TFont): Integer;
var
OldFont : TFont;
begin
OldFont := TFont.Create;
try
OldFont.Assign( CanvasOWner.Font );
CanvasOWner.Font.Assign( TextFont );
Result := CanvasOwner.Canvas.TextWidth(Text);
CanvasOWner.Font.Assign( OldFont );
finally
OldFont.Free;
end;
end;

"Почему некоторые визуальные компоненты типа TPanel и TEdit не имеют свойства Canvas?"

Все наследники TCustomControl имеют свойство Canvas, тем не менее, необходимо иметь какой-то механизм защиты для того, чтобы другие "художники" не могли рисовать на компоненте. Наследники компонента всегда имеют доступ к защищенным свойствам, которые они наследуют от компонента (как, например, Canvas), но те же пользователи компонента к ним доступа не имеют.

type
TCanvasPanel = class(TPanel)
public
property Canvas;
end;

Если вы хотите рисовать на компоненте, не имеющим опубликованного свойства canvas, попробуйте использовать другой компонент, позволяющий рисовать на нем (TPaintBox), или компоненты-слои, позволяющие достигнуть того же результата (client-align у TPaintBox внутри TPanel позволяет получить окантуренную область с возможностью рисования).

"Как мне получить горизонтальную полосу прокрутки в компоненте ListBox?"

Пошлите сообщение LB_SetHorizontalExtent оконному дескриптору компонента ListBox. Например, сообщение можен быть послано в обработчике события формы OnCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
SendMessage(Listbox1.Handle, LB_SetHorizontalExtent, 1000, Longint(0));
end;

"Имеет ли Delphi компонент, поддерживающий последовательные коммуникации (порты)?"

Нет. Тем не менее, существуют библиотеки для работы с последовательными портами (и скоро должны появиться компоненты) для Delphi третьих фирм, как, например, TurboPower, SaxComm и других.

"Каким образом можно установить табуляторы в элементе управления TMemo?"

Для установки табулятора в компоненте многострочного редактирования (например, TMemo), пошлите ему сообщение EM_SetTabStops. Массив Tabs указывает на месторасположение табуляторов. Поскольку параметр WParam в SendMessage равен 1, то все табуляторы будут установлены в величину, передаваемую в массиве Tabs. Не забывайте для включения табуляторов устанавливать свойство WantTabs компонента TMemo в True.

procedure TForm1.FormCreate( Sender : TObject );
const
TabInc : LongInt = 10;
begin
SendMessage( Memo1.Handle, EM_SetTabStops, 1, Longint( @TabInc ) );
end;

"Какое наилучшее место в коде программы, откуда можно вызвать окно с логотипом программы при ее запуске?"

Наилучшее место для показа окна с логотипом - в исходном коде проекта после первого Application.FormCreate и перед Application.Run. Этим мы осуществляем создание формы на лету и показ ее до момента фактического запуска приложения.

program Project1;

uses Forms, Unit1 in 'UNIT1.PAS' {Form1}, Splash;

{$R *.RES}
var
SplashScreen : TSplashScreen;  {в модуле Splash}
begin
Application.CreateForm(TForm1, Form1);
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
SplashScreen.Update; {Обрабатываем любые сообщения Windows, касающиеся отрисовки}
{
осуществите остальные CreatForms или другие
действия прежде чем приложение запустится. Если процедура запуска
имеет продолжительное время, то для того, чтобы окно реагировало
на системные сообщения, необходимо переодически давать команду
Application.ProcessMessages.
}
finally               {Убедитесь что окно с логотипом освобождается}
SplashScreen.Free;
end;
Application.Run;
end.

"Почему, когда пользователь нажимает на кнопке SpeedButton, у компонента TEdit не возникает события OnExit? Существует ли способ заставить генерироваться событие OnExit при нажатии на кнопке SpeedButton?"

SpeedButton в действительности никогда не получает фокуса, поэтому активный элемент управления его и не теряет, следовательно, у активного элемента управления события OnExit не происходит.

Имеется единственный способ вызвать событие OnExit у активного элемента управления - вызвать его явно при наступлении события OnClick у кнопки SpeedButton. Для примера:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
If ActiveControl is TEdit then
(ActiveControl as TEdit).OnExit(ActiveControl);
end;

"Во время выполнения программы каждое вновь открытое дочернее окно возникает немного ниже и правее предыдущего. Моя проблема заключается в том, что когда я закрываю какое-либо дочернее окно и открываю новое, оно появляется правее и ниже того, которое я закрыл перед этим, даже если оно было единственным, по каким правилам это писалось?"

Так работают дочерние MDI окна. В этой ситуации VCL не перекрывает поведения Windows, такие правила диктует сама система.

Непроверенное предположение: В процедуре FormCreate попробуйте установить необходимые значения свойствам Top, Left, Width и Height. FormCreate дочерней MDI формы будет вызвано прежде, чем будет показано само окно.

"Почему моя программа не может найти ресурсы, упакованные мной в .RES-файл, если .RES-файл имеет то же самое имя, что и модуль формы?"

Если имя используемого вами .RES-файла совпадает с именем .DPR-файла, Delphi перезапишет его, создав собственный .RES-файл с этим именем. Кроме того, проектный RES-файл предназначен только для менеджера Delphi-проекта, не редактируйте и не добавляйте к нему свои ресурсы.

"Существует ли функция прокрутки формы с помощью клавиш? Например, прокрутка вверх и вниз при нажатии PgUp и PgDown соответственно.

Прокрутка формы осуществляется с помощью изменения свойства Position свойства формы VertScrollbar или HorzScrollbar. Следующий код показывает как это можно сделать:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
PageDelta = 10;
begin
With VertScrollbar do
if Key = VK_NEXT then  Position := Position+PageDelta
else if Key = VK_PRIOR then Position := Position-PageDelta;
end;

Примечание: Это может не работать, если активный элемент управления (типа TMemo) также использует PgUp & PgDn.

"Существует ли способ заполнения TListbox или TMemo за один проход?"

Для заполнения сразу нескольких строк в компоненте TListbox или TMemo может использоваться метод SetText. Методу SetText передается строка с терминирующим нулем, где каждая строка сопровождается разделителем, символом возврата каретки - #13. Пояснительный пример:

Listbox1.Items.SetText('aaaaa'#13'bbbbb'#13'ccccc')

При этом ListBox отобразит следующий текст:

   aaaaa
   bbbbb
   ccccc
Примечание: Предпочтительным методом заполнения ListBox или Memo является метод Add их соответствующих свойств Items и Lines.

"Возможно ли создание аналога массива элементов управления, применяемого в Visual Basic? Например, я хочу иметь группу кнопок с общим обработчиком события, с помощью которого я мог бы определить нажатую кноку или ее порядковый номер. В Visual Basic это можно было сделать с помощью индекса управляющего массива (Control Array)."

Один из способов решения задачи состоит в присваивании полю Tag уникального числа, создание общего обработчика события для всех кнопок и проверки содержимого поля Tag передаваемого объекта Sender. Назначьте всем кнопкам группы один и тот же обработчик события OnClick. Обработчик события должен выглядеть приблизительно так:

procedure TForm1.Button1Click(Sender: TObject); var cap: string;
begin
case TButton(sender).Tag of
1: ShowMessage('Нажата первая кнопка');
2: ShowMessage('Нажата вторая кнопка');
2: ShowMessage('Нажата третья кнопка');
end;
end;

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

При добавлении компонента на страницу TabbedNotebook во время выполнения программы, ссылка на желаемую страницу должна быть назначена свойству нового компонента Parent прежде, чем она будет показана. Получить доступ к страницам TTabbedNotebook во время выполнения программы можно через элементы-объекты свойства-массива 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])

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

Такую характеристику поддерживает продукт фирмы TurboPower Orpheus. Для получения дополнительной информации посетите сервер компании TURBOPOWER.

"Существует ли простой способ использования CopyToClipboard, CutToClipboard с компонентом TEdit, имеющим фокус?

Просто проверьте, имеет ли ActiveControl тип TEdit, и, если да, то выполняйте желаемую операцию: вырезайте, копируйте или вставляйте. Для примера:

if (ActiveControl is TEdit) then
TEdit(ActiveControl).CopyToClipboard;

"Компонент TDBGrid имеет события OnMouseDown, OnMouseUp и OnMouseMove?"

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

"Расходует ли Delphi системные ресурсы при открытии и закрытии модальных окон? Например, следующий код уменьшает системные ресурсы при каждом показе модального диалога:"

ModalForm1 := TModalForm1.Create(Self);
ModalForm1.ShowModal;

В отсутствие обработчика OnClose установите параметр Action в caFree, ваш код создает каждую новую форму вызовом TModalForm1.Create(Self), но предыдущий экземпляр формы не уничтожается. Все предыдущие экземпляры форм "ModalForm1" так и остаются "болтаться" в Windows.

Чтобы форма освобождала свои ресурсы, можно также использовать метод Free. Вот демонстрация этого метода:

try
ModalForm1.ShowModal;
{ здесь размещается необходимый код }
finally
ModalForm1.Free;
end;

"Какое лучшее решение для создания группы RadioGroup и размещения в ней кнопок RadioButton? Кажется, я просто могу создать компонент RadioGroup и набросать туда несколько RadioButton, или все же лучше создать RadioGroup, задать значение свойству Items, тем самым определив заголовки элементов (RadioButton) и разместив их в группе?"

Если вы собираетесь использовать RadioGroup, то логичным будет для создания RadioButton воспользоваться списком строк Items. При этом RadioButton не должны быть объединены в одну группу, эта причина того, почему к элементу RadioGroup нельзя обратиться как к отдельному компоненту RadioButton.

"Существует ли способ убедить окно, содержащее форму или изображение, в byte-aligned (выравнивании байтов)?"

Перекройте метод CreateParams:

procedure TMyForm.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(Params);
Style := Style or CS_BYTEALIGNWINDOW;
end;

Примечание: Байтовое выравнивание практически не описано в документации по Windows. Имеет значение только для черно-белого, EGA и 16-цветного VGA видео-режима. Все режимы с более высоким разрешением всегда выравнивают байты.

Какой порядок наступления событий при создании и показе формы?

При создании формы события наступают в следующем порядке: OnCreate, OnShow, OnPaint, OnActivate, OnResize и снова OnPaint.

"Почему, если в обработчике формы OnActivate изменить свойство FormStyle, возникает ошибка 'Cannot change Visible in OnShow or OnHide' (не могу изменить Visible (видимость) в OnShow или OnHide)?

Свойство FormStyle определяет стиль создаваемого окна и обычно устанавливается в обработчике события OnCreate, тем не менее, вы можете его изменить и после создания дескриптора окна, только не в обработчиках событий OnActivate, OnShow или OnHide. Ваша проблема заключается в том, что вы пытаетесь изменить стиль формы при возникновении событий OnShow и OnHide.

"Каким образом я могу сделать у компонента границы типа "sunken" (углубленный) или "raised" (выпуклый)?

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

Где я могу найти исходный код страничных компонентов (например, TTabbedNotebook)?

Исходный код VCL не содержит код "tab"-компонентов из-за юридических причин. Тем не менее, исходники интерфейса (interface source) расположены в каталоге DELPHI\DOC и имеют расширение INT.

Примечание: зарегистрированные владельцы исходного кода Delphi RTL могу запросить исходный код TTabSet и TTabbedNotebook у подразделения Borland Corporate Affairs. Инструкция находится в файле readme исходного кода RTL. [000892]


Delphi 1

FAQ 5 VCL (2 из 2)

"Какой объем текста может содержать компонент Delphi Memo?"

Элементы редактирования Microsoft, интегрированные в Windows и применяющиеся в Delphi компонентах-обертках TEdit и TMemo, имеют ограничение по объему текста, равное 32К. Delphi классы-оболочки имеют специальный механизм, позволяющий каждому элементу управления типа Edit или Memo, размещенному на форме, содержать до 32К текста. При нормальной ситуации суммарный предел всех элементов редактирования приложения ограничен 32К.

"Как мне сделать так, чтобы определенное поле в компоненте TGrid не выводилось?"

Это может быть сделано с помощью простого удаления поля из списка полей Fields Editor или установки свойства поля Visible в False.

"Существует ли способ задания заднего фона в виде изображений в приложениях MDI?"

Существует демонстрационный пример, показывающий как это можно сделать, он расположен в секции VCL (5) форума Delphi под именем MDI_BGRD.ZIP.

"Существует ли в Delphi денежный компонент?"

Нет, но существует компонент редактирования денежных сумм в секции VCL форума Delphi под именем CURREDIT.ZIP.

"Где мне найти информацию о типах данных VBX (например, TBasicString) и функции для работы с ними?"

Во-первых, все поддерживаемые типы данных VBX и функции для работы с ними находятся в модуле VBXCtrls, но он хранится в виде объектного файла. Тем не менее, Delphi имеет секцию интерфейса данного модуля, находящуюся в каталоге \DELPHI\DOC под именем VBXCTRLS.INT. Реально это единственный источник информации о содержании модуля VBXCtrls.

"Какие вопросы я должен учесть при создании приложения, ориентированного на работу при различных разрешениях экрана (масштабирование форм)?"

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

  • Заранее, в самом начале этапа разработки, решите для себя - собираетесь ли вы разрешать масштабировать форму или нет. Преимущество запрета масштабирования в том, что вам ничего не нужно менять во время выполнения приложения. Недостаток запрета масштабирования - во время выполнения приложения никаких изменений не происходит (ваша форма может быть слишком малой или слишком большой для работы в некоторых режимах при отсутствии масштабирования).
  • Если вы НЕ собираетесь масштабировать форму, установите свойство Scaled в False.
  • В противном случае, установите свойство формы Scaled в True.
  • Установите AutoScroll в False. AutoScroll = True означает 'не изменять размер окна формы во время выполнения приложения', что приводит к "плохому виду" формы, если ее содержимое меняет размер.
  • Установите шрифты формы в масштабируемые TrueType-шрифты типа Arial. MS San Serif также подойдет в качестве альтернативы, только помните, это не TrueType, а bitmapped-шрифт. Только Arial может правильно изменять свою высоту с дискретностью 1 пиксел. Примечание: Если используемый шрифт не установлен на машине пользователя, Windows выбирает альтернативный шрифт из данной линейки (семьи) шрифтов. Размеры нового шрифта могут отличаться от размеров оригинального шрифта, что также может вызвать проблемы.
  • Установите свойство формы Position во что-нибудь другое, чем poDesigned. poDesigned всегда показывает форму в первозданном виде, и, если форма разрабатывалась в разрешении 1280x1024, то вы можете себе представить, что будет при разрешении 640x480?
  • Не "слепляйте" на форме элементы управления, оставляйте между ними, по крайней мере, 4 пикселя, в противном случае, при изменении месторасположения границы на 1 пиксель (это происходит при масштабировании), элементы управления наедут друг на друга.
  • Для однострочных компонентов Label, у которых свойство Aligned равно alLeft или alRight, установите AutoSize в True. В противном случае, установите AutoSize в False.
  • Убедитесь в том, что компоненты Label имеют достаточный запас по ширине (требуется, примерно, 25%) от длины текущего текста. (При переводе вашего приложения на другие языки вам необходимо примерно 30%-ный запас от текущей ширины текста). Если AutoSize - False, убедитесь, что ширины компонента Label достаточно для размещения реального текста. Если AutoSize - True, убедитесь, что на компоненту Label достаточно места (например, на форме) для размещения всего текста плюс небольшой запас для его роста при смене шрифтов.
  • В случае многострочного текста и компонентов Label с переносом слов, убедитесь, что в нижней части у вас имеется, по крайней мере, еще одна строчка. Она необходима вам для того, чтобы не допустить переполнения строки, если размер шрифта увеличивается при масштабировании. Не думайте, что, если вы используете большие шрифты и переполнения не возникает, то эта проблема снята - кто-нибудь может использовать шрифты с еще большим размером, чем у вас!
  • Будьте осторожными при открытии проекта в IDE с другим разрешением. Свойство формы PixelsPerInch будет изменено как только вы откроете форму, и сохранено в DFM-файле при сохранении проекта. Лучше всего запускать приложение отдельно от IDE, а редактировать его при одном разрешении. Редактируя формы при различных разрешениях и размерах шрифтов, вы инициируете проблему "дрейфа" компонентов по форме и изменения их размера.
  • Говоря о дрейфе компонент, не следует многократно масштабировать форму, как во время разработки, так и во время выполнения приложения. Каждое изменение размеров сопровождается ошибками округления, которые достаточно быстро накапливаются с тех пор, как координаты стали строго целочисленными. Поскольку при калькулировании новых размеров дробная часть отбрасывается, вновь пересчитанные размеры оказываются меньше, а координаты элементов управления северо-западнее. Если вы решили разрешить пользователю изменять масштабы форм, начинайте масштабирование с последней загруженной/созданной формы, этим вы уменьшите накапливаемые при масштабировании ошибки.
  • Старайтесь не изменять значение свойства формы PixelsPerInch.
  • В общих словах, нет необходимости разрабатывать формы для всех возможных режимов, перед окончательным релизом вашего приложения вы должны оценить поведение формы в пограничных режимах - 640x480 с маленькими и большими шрифтами, и при высоком разрешении и, также, с маленькими и большими шрифтами. Это должно быть частью ваших регулярных проверок на предмет системной совместимости, для ведения так называемой тестирующей контрольной таблицы.
  • Обратите пристальное внимание на "однострочные компоненты TMemo" - типа TDBLookupCombo. Системные многострочные редакторы всегда выводят только целые строки текста - если ширина элемента управления слишком мала для своего шрифта, то TMemo вообще ничего не показывает (TEdit показывает обрезанный текст). Размер таких компонентов лучше сделать на несколько пикселей больше, чем на несколько пикселей меньше, тем самым можно определеть наличие в компоненте оставшейся части текста.
  • Обратите внимание на то, что масштабирование во время проектирования и во время выполнения программы отличается коэффициентом и зависит от высоты шрифта, а не от экранного разрешения в пикселях. Помните также, что "начало" компонент будет изменяться в зависимости от масштаба формы, и для их "броуновского" движения также необходимо небольшое пространство.
"Как мне избавиться от заставки ReportSmith при запуске генерации моего отчета?"

Добавьте следующую строку в секцию [RS_RunTime] файла RS_RUN.INI, это позволит избежать появления логотипа при запуске ReportSmith:

   ShowAboutBox=0
"Как мне создать окно с несколькими секциями изменяемого размера?"

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

  1. Разместите на форме компонент Memo и установите его свойство Align в alTop.
  2. Разместите на форме панель и установите ее свойство Align в alTop.
  3. Установите у панели свойство Height в величину 6 или 7.
  4. Установите у панели свойство DragMode в dmAutomatic.
  5. Установите у панели свойство DragCursor в crVSplit.
  6. Установите у панели свойство Cursor в crVSplit.
  7. Добавьте на форму другой компонент Memo и установите его свойство Align в alClient.
  8. Создайте общий для компонентов Memo и Panel обработчик события OnDragOver как показано ниже:

    procedure TForm1.Memo1DragOver(Sender, Source: TObject; X,
    Y: Integer; State: TDragState; var Accept: Boolean);
    begin
    Accept := False;
    if Source = Panel1 then begin
    Accept := True;
    Memo1.Height := Y + (Sender as TControl).Top;
    end;
    end;

"Как мне определить текущую колонку и строку курсора в компоненте TMemo?

C помощью сообщений Windows API EM_LINEFROMCHAR и EM_LINEINDEX вы можете определить строку и положение курсора в строке (начало SelStart):

var
LineNum: longint;
CharsBeforeLine: longint;
begin
LineNum := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart,0);
CharsBeforeLine := SendMessage(Memo1.Handle, EM_LINEINDEX, LineNum, 0);
Label1.Caption := 'Строка ' + IntToStr(LineNum +1)
Lebel2.Caption := 'Позиция ' + IntToStr((Memo1.SelStart - CharsBeforeLine) + 1);
end;

Как мне получить количество пикселей на дюйм, поддерживаемое принтером?

Если необходима величина в пикселах, можно воспользоваться API функцией GetDeviceCaps(). Для примера:

VertPixelsPerInch := GetDeviceCaps(Printer.Handle, LogPixelsX);
HorzPixelsPerInch := GetDeviceCaps(Printer.Handle, LogPixelsY);

"Возможно ли хранение целочисленной величины вместе со строкой в объекте списка TString или каком-либо свойстве?"

Да, но это потребует некоторых преобразований типов. Компонент TString вместе с массивом строк имеет массив объектов, который может использоваться с целью хранения целочисленных данных: типом данных для массива объектов служит TObject. В сущности, он хранит значение указателя размером 4 байта. Поэтому для хранения в нем целочисленной величины необходимо приведение типа значения. Для примера, следующий код добавляет строку и целое число 100 к свойству items (объект TString) компонента Listbox:

Listbox1.Items.AddObject('Текстовая строка', TObject(100));

Для получения значения сделайте следующее:

Result := LongInt( Listbox1.Items.Objects[0] );

Здесь подразумевается, что Result имеет тип Longint и значение хранится в объекте с индексом 0.

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

Если вам необходимо хранить более одного значения, создайте новый, производный от TObject, класс и сделайте необходимые объявления:

type
ManyValues = class(TObject)
Value1 : Integer;
Value2 : Integer;
end;
...

Возможно ли получить доступ к компонентам по их имени (например, 'SpeedButton' + IntToStr(i) )?

Да, это возможно. Следующий пример использует метод FindComponent формы Form1 для выключения первых 10 компонентов SpeedButton по их имени.

for I := 1 to 10 do
with Form1.FindComponent('SpeedButton' + IntToStr(i)) as TSpeedButton do
Enabled := False;

Как вы создаете 'модальную' форму в MDI-приложении? Когда мое приложение вызывает метод ShowModal, я получаю ошибку "Can't Show Modal when Visible is set true" (не могу показать в модальном режиме, поскольку свойство видимости установлено в истину). При попытке установить Visible в False, я получаю ошибку с сообщением о том, что на дочерней MDI форме я не могу установить свойство Visible в False.

По технологии, первая форма проекта (главная форма) создается со свойством Visible, установленным в True, а все остальные формы при создании имеют свойство Visible, установленное в False. С другой стороны, дочерняя MDI форма не может быть невидимой, поэтому ее свойство Visible установлено в True. Когда вы изменяете стиль формы на fsNormal, свойство Visible имеет значение True, поэтому в False его необходимо установить вручную.

Возможно ли изменения размера шрифта компонентов, размещенных на форме, задаваемого по умолчанию?

Просто добавьте форму с установленным по желанию свойством Font в галерею. Причина: располагаемые на форме компоненты рефлекторно принимают настройки шрифта родительской формы. Кроме того, вы можете установить вашу новую форму как главную форму по умолчанию и также поместить ее в галерею (Options | Gallery...).

Как мне определить каталог, из которого запущено мое приложение?

Следующая функция извлекает путь из свойства ExeName глобального объекта Application:

function GetExePath : String;
var
LastBackSlashPos, Index : Integer;
begin
Result := Application.ExeName;
for Index := 1 to length(Result) do
if Result[Index] = '\' then
LastBackSlashPos := Index;
{ вычитаем 1 для невключения последней косой черты }
Result[0] := chr(LastBackSlashPos - 1);
end;

Как мне изменить Font.Style на нормальный после вызова Canvas.Font.Style := [fsBold]? В справке указаны стили ([fsBold],[fsItalic] и др.], но не указан нормальный стиль.

Просто определите пустое множество для набора стилей:

Canvas.Font.Style := [];

или просто исключите стиль жирного шрифта следующим образом:

Canvas.Font.Style := Canvas.Font.Style - [fsBold];

Как мне совершить некоторые действия после того, как форма будет нормально показана? Похоже, что все события формы (OnCreate, OnPaint и др.) происходят еще до того, как форма станет видимой.

В обработчике события OnPaint вы можете добавить "Visible := True" и делать все что хотите.

В каком количестве компоненты используют GDI ресурсы?

Потомки TGraphicControl типа TLabel и TBevel не используют свободные системные ресурсы вообще. Используют их потомки TWinControl типа TEdit и TPanel. Также каждая радио-кнопка в TRadioGroup является окном, т.е. имеет дескриптор окна.

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

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

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

...
private
{ Private declarations }
PROCEDURE CreateParams(VAR Params: TCreateParams); override;
...
procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
with Params do begin
WndParent := Application.MainForm.Handle;
Style := (Style OR WS_CHILD) AND NOT (WS_POPUP);
end;
end;

Свойство дочерней формы BorderStyle должно быть установлено в bsNone. В главной форме создайте закрытое поле данных с типом TForm. Инициализируйте его при наступлении события OnActivate, НЕ OnCreate. Теперь при каждом щелчке на закладке "смены страниц" освобождаем текущую дочернюю форму и создаем новую необходимого типа. Например, при наступлении события OnActivate:

Child := TForm2.Create(Self);
with Child do begin
Parent := Self;
Align := alClient;
Visible := True;
end;

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

Как мне отменить выбор одного или нескольких элементов в компоненте Listbox или ComboBox?

Listbox1.ItemIndex := -1;

Почему, при вызове диалогового окна, например, MessageBox(), из обработчика события OnExit, мерцающий курсор исчезает при закрытии диалога?

Это стандартное поведение Windows. Форсирование дополнительного изменения фокуса (например, с помощью ShowMessage) в течение обработки события, связанного с фокусом, (например, OnExit) может вызвать непредсказуемые действия со стороны Windows. Это Windows, которое управляет передачей фокуса, и это Windows, которое может вызвать неадекватную реакцию, если вы заставляете его изменить фокус в середине этого процесса.

Почему я получаю исключительную ситуацию 'EInvalidOperation: Cannot make a visible window modal' (не могу сделать модальное окно видимым), если я открываю форму с помощью метода Showmodal? Форма при этом не открывается.

Убедитесь, что свойство формы Visible не устанавливается в True во время проектирования или во время выполнения программы. [000894]


Delphi 1

FAQ 6, Базы данных

Примечание: DataSet (набор данных) используется компонентами TTable, TQuery, и TStoredProc для связи с базой данных.

"Где мне можно получить помощь по работе с ReportSmith, InterBase и связке SQL Links/ODBC?"

Воспользуйтесь борландовским форумом разработчиков (BDEVTOOLS). В нем присутствуют группы, посвященные работе с ReportSmith, InterBase, Borland Database Engine, SQL Links/ODBC connectivity и др.

"У меня имеется TQuery и TDataSource. Cвойстве TStrings TQueryI имеет значение 'SELECT * FROM dbo.AnyTable', где dbo - база данных на моем SQL-сервере. Когда я устанавливаю свойство active в TRUE, я получаю следующую ошибку: 'Token not found. Token :dbo. line number:1'. В чем дело?"

Если свойство RequestLive установлено в True, тогда имя базы данных и таблицы необходимо указывать в кавычках:

Пример:
SELECT * FROM "dbo.table"

Если свойство RequestLive установлено в False, кавычки не нужны.

Пример:
SELECT * FROM dbo.table

"При попытке запустить приложение для работы с БД из-под Delphi, я получаю исключение EDatabaseError с сообщением 'An error occurred while attempting to initialize the Borland Database Engine (Error $2C09) (Ошибка при инициализации BDE)'."

Добавьте SHARE.EXE в ваш файл AUTOEXEC.BAT или добавьте DEVICE=VSHARE.386 в секцию [386Enh] вашего файла SYSTEM.INI и перегрузитесь.

"У меня есть Quattro Pro 6.0 и IDAPI для работы в сети. После установки Delphi и нового IDAPI поверх сетевого IDAPI и, запуская Quattro Pro с другой машины, я получаю ошибку о том, что невозможно загрузить драйвер языка (Language Driver)."

Добавьте в секцию [Borland Language Drivers] файла WIN.INI строчку, содержащую путь к каталогу IDAPI/LANGDRV. Для примера:

     [Borland Language Drivers]
     LDPATH=C:\IDAPI\LANGDRV
"Что значит ошибка IDAPI $2C08?"

"Не могу загрузить IDAPI01.DLL". Убедитесь, что в вашем файле WIN.INI в секции, указанной ниже, в переменной DLLPATH указан корректный путь к IDAPI:

     [IDAPI]
     DLLPATH=C:\IDAPI
     CONFIGFILE01=C:\IDAPI\IDAPI.CFG
"Почему я получаю 'Index out of range' (индекс за пределами диапазона), когда я использую tTable.FindNearest и tTable.FindKey в таблице dBASE с выражением индекса (expression index)?"

FindKey и FindNearest не хотят работать с выражениями индексов dBASE. Для нормальной работы с выражением индексов dBASE используйте методы класса tTable GoToKey и GotoNearest.

"Какой в Delphi эквивалент Paradox TCursor?"

Компонент TTable.

"Каким образом, программным путем, создать таблицу Paradox с автоприращиваемым (Auto Increment) типом поля? Я использую TTable.CreateTable, но TFieldType не имеет этот тип полей."

Используйте TQuery или SQL-запрос CREATE TABLE. Для примера:

procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
DatabaseName := 'DBDemos';
with SQL do
begin
Clear;
Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
Add('Name CHAR(255),');
Add('PRIMARY KEY(ID))');
ExecSQL;
Clear;
Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
ExecSQL;
end;
end;
end;

"Как мне узнать, какая запись и какое поле TDBGrid в данный момент являются текущими?"

Вот метод, следящий за текущими колонкой и строкой. Приведенный ниже код в методе MyDBGridDrawDataCell обновляет переменные Col и Row (которые не должны быть локальными для метода) при каждой отрисовке табличной сетки. Используя данный код, вы всегда с помощью переменных Col и Row можете узнать номер текущей колонки и строки соответственно.

var
Col, Row: Integer;

procedure TForm1.MyDBGridDrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
RowHeight: Integer;
begin
if gdFocused in State then
begin
RowHeight := Rect.Bottom - Rect.Top;
Row := (Rect.Top div RowHeight) - 1;
Col := Field.Index;
end;
end;

"Как мне выделить текущую строку в TDBGrid?"

В свойстве TDBGrid Options выставьте флаг dgRowSelect.

"Как мне создать маску в компоненте TDBEdit?"

Маски редактирования применимы к полям таблицы (компоненты TField), а не к управляющим элементам управления для работы с базами данных. Дважды щелкните на иконке TTable и добавьте необходимые поля таблицы. Когда поле выделено, его свойства появляются в Инспекторе Объектов, включая редактор маски. Связывание поля с TDBEdit позволяет решить эту проблему.

"Существует ли простой способ перехватывать исключения в событиях элементов управления?"

Создайте метод формы для перехвата исключений. Данный метод вызывает метод приложения (объект Application) OnException. В нем необходимо производить проверку на необходимые вам исключения, например, EDatabaseError. Откройте файл справки и посмотрите информацию о событии OnException. Там ясно и достаточно подробно описан процесс создания обработчика данного события. Для примера:

Procedure TForm1.MyExcept(Sender:TObject; E:Exception);
{Не забудьте предварительно объявить класс}
begin
If E is EDatabaseError then
MessageDlg('Перехвачено исключение', mtInformation, [mbOk], 0)
else
{ если эта не та ошибка, которую вы ищите, передайте объект исключительной ситуации дальше }
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := MyExcept;
{ Мы только что назначили обработчика события OnException }
end;

"Какие версии Informix (Online, I-NET) поддерживают SQL Links?"

SQL Links прекрасно работает со всеми версиями Informix sever, включая версию 5.01. Тем не менее она не совместима с новыми версиями их клиентов (клиент Windows версии 5.0). В случае клиентов вам надлежит пользоваться клиентом версии 4.2 (для DOS).

"Вы можете дать определение 'IDAPI'? What is 'SQL Links'?"

IDAPI - Integrated Database Application Program Interface (интегрированный программный интерфейс приложений баз данных). BDE позволяет получить доступ к множеству источников данных с последовательным API. IDAPI - именно API для BDE. Оно включает в себя все функции, необходимые для получения доступа, манипуляции данными и т.п.: Delphi, dBASE for Windows и Paradox for Windows пользуются данными функциями для получения доступа к данным: вы также можете использовать их в своих программах. С приобретением BDE вы также получаете всю необходимую документацию. В ней содержится перечень всех доступных функций с описанием того, что они делают. Если вы посмотрите исходные файлы Delphi, вы увидите как используются там эти функции. Названия функций имеют префикс "Dbi" (например, DbiCreateTable).

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

"IDAPI необходим для доступа к данным в Delphi? Может быть как-то 'упрятать' IDAPI внутрь Delphi EXE-файла, чтобы не устанавливать IDAPI на каждом компьютере пользователя вдобавок к моей программе?"

IDAPI необходим для доступа к данным в Delphi. Delphi поставляется с дискетой, содержащей установку IDAPI.

"Как мне изменить цвет ячейки TDBGrid?"

Создайте следующий обработчик события компонента TDBGrid OnDrawDataCell:

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;

Установите отрисовку по умолчанию в True. Только таким способом можно нарисовать отдельную ячейку. Если же вы установили DefaultDrawing в False, вам необходимо будет самим отрисовать все ячейки, используя свойства canvas.

"Каким образом можно недопустить появление диалогового окна с запросом пароля, если я открываю таблицу, защищенную паролем?"

Просто обеспечьте объект Session паролем, который необходимо ввести для открытия таблицы:

Session.AddPassword ('PASSWORD');

При закрытии таблицы вы можете удалить пароль с помощью команды RemovePassword('PASSWORD'), или удалить все текущие пароли с помощью RemoveAllPasswords. (Примечание: все вышесказанное относится только к таблицам Paradox)

"Где мне найти список и описание функций BDE и типов данных?"

DBIPROCS.INT в вашем каталоге DELPHI\DOC\ содержит список функций BDE, ожидаемые параметры, возвращаемые значения и их краткое описание. DBITYPES.INT - список типов, используемых функциями BDE. Для вызова любой из функций BDE необходимо наличие следующих модулей с списке USES: DBITYPES, DBIPROCS и DBIERRS. Для получения более подробной информации по использованию функций IDAPI, закажите руководство "Database Engine User's guide" в службе поддержки пользователей.

"Может ли BDE API или другие доступные DLL воссоздавать разрушенные индексы (типа TUTILITY.EXE, поставляемое с Pdoxwin)?"

Функция BDE для воссоздания индексов называется DbiRegenIndexes().

Добавьте следующие модули в секцию USES: DBITYPES, DBIPROCS и DBIERRS. Затем вы можете вызвать функцию следующим образом:

DBIRegenIndexes(Table1.Handle);

Примечание: Таблица должна быть открыта в эксклюзивном режиме и индекс должен уже существовать.

"Может ли BDE API или другие доступные DLL паковать таблицы dBASE?"

Функция BDE для пакования таблиц dBASE называется DbiPackTable().

Добавьте следующие модули в секцию USES: DBITYPES, DBIPROCS и DBIERRS. Затем вы можете вызвать функцию следующим образом:

DBIPackTable(Table1.DbHandle, Table1.Handle, 'TABLENAME.DBF', szDBASE,
TRUE);

Примечание: Таблица должна быть открыта в эксклюзивном режиме.

"Возможно ли программным путем добавить псевдоним к файлу IDAPI.CFG?"

Функция BDE, осуществляющее это, называется DbiAddAlias(). Спецификация доступна в Section 6 (Database) библиотеки, файл AddAlias.txt. Также в Section 6 (Database) библиотеки доступен компонент AliasManager. С помощью него возможно создание, удаление и редактирование псевдонимов.

"Как мне посмотреть dBASE-записи, помеченные для удаления?"

В обработчике события AfterOpen вызовите нижеприведенную функцию. Вы также должны включить DBITYPES, DBIERRS, DBIPROCS в список используемых модулей. При вызове функции укажите в качестве аргументов TTable и TRUE/FALSE для показа/скрытия удаленных записей. Например:

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;

"Как в табличной сетке создать колонку, куда будут заноситься записи из таблицы dBASE, помеченных для удаления?"

Создайте вычисляемые поля, затем в обработчике события таблицы OnCalcField замените вычисляемые поля, которые вы создали, следующим образом:

procedure TForm1.Table1CalcFields(DataSet: TDataset);
var
RCProps : RecProps;
Result : DBIResult;
begin
Result := DbiGetRecord(Table1.Handle, dbiNoLock, Nil, @RCProps);
If RCProps.bDeleteFlag then Table1Del.Value := 'X' else
Table1Del.Value := '';
end;

Примечание: Сначала вы должны вызвать функцию SetDelete(TTable,TRUE), описанную в предыдущем вопросе.

"Как мне определить реальный размер 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
{ Поле редактирования Edit1 будет показывать }
{ размер memo-поля с именем Notes.           }
Edit1.Text := IntToStr(GetBlobSize(Notes));
end;

"Как мне показать содержимое memo-поля в DBGrid?"

Используйте расположенный ниже код в обработчике события OnDrawDataCell компонента DBGrid. Примечание: перед созданием объекта TMemoField дважды щелкните на компоненте TTable и добавьте memo-поле.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
P  : array [0..50] of char;   {размер массива - необходимое число символов}
BS : tBlobStream;             {из memo-поля}
S  : 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;
S := StrPas(P);
while Pos(#13, S) > 0 do              {удаляем символы перевода строки и}
S[Pos(#13, S)] := ' ';              {пропуска страницы}
While Pos(#10, S) > 0 do
S[Pos(#10, S)] := ' ';
FillRect(Rect);                {очищаем ячейку}
TextOut(Rect.Left, Rect.Top, S);         {заполняем ячейку данными memo}
end;
end;
end;

"Существует ли способ для ввода данных использовать клавишу Enter вместо Tab или клавиши мыши?"

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

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If Key = #13 Then
Begin
SelectNext(Sender as tWinControl, True, True );
Key := #0;
end;
end;

Это заставляет клавишу Enter вести себя подобно клавише Tab. После этого выберите на форме все элементы управления (за исключением кнопок), у которых вы хотели бы видеть такую функциональность, и в Инспекторе Объектов сошлитесь в обработчике события OnKeyPress на созданную процедуру EditKeyPress. Теперь каждый компонент, который вы выбрали, будет воспринимать клавишу Enter как Tab. Если вы хотели видеть данную функциональность на уровне формы (по сравнению с элементами управлениями), сотрите в Инспекторе Объектов у всех элементов обработчики событий OnKeyPress и сошлитесь на созданную процедуру EditKeyPress в обработчике OnKeyPress _формы_. Затем измените Sender на ActiveControl и установите свойство формы KeyPreview в True:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If Key = #13 Then
begin
SelectNext(ActiveControl as tWinControl, True, True );
Key := #0;
end;
end;

Это позволит любому элементу на форме (по возможности) воспринимать клавишу Enter как клавишу Tab.

"Как мне воспользоваться функцией locate в неиндексированном поле?"

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

Locate(Table1, Table1LName, 'Beman');

Table1 - компонент Table, Table1LName - TField, добавляемое вами с помощью редактора полей (двойной щелчок на компоненте Table) и 'Beman' - имя, которое вы хотите найти.

(* Функция Locate находит SValue в неиндексированной таблице *)
Function Locate( const oTable: TTable; const oField: TField;
const sValue: String): Boolean;
var
bmPos  : TBookMark;
bFound : Boolean;
begin
Locate := False;
bFound := False;
If not oTable.Active then Exit;
If oTable.FieldDefs.IndexOf( oField.FieldName ) < 0 then Exit;
bmPos := oTable.GetBookMark;
With oTable do
begin
DisableControls;
First;
While not EOF do
if oField.AsString = sValue then
begin
Locate := True;
bFound := True;
Break;
end
else Next;
end ;
If (Not bFound) then oTable.GotoBookMark( bmPos);
oTable.FreeBookMark( bmPos );
oTable.EnableControls;
end;

"Почему я не могу использовать опцию ixUnique при создании индекса таблицы Paradox с помощью метода AddIndex компонента TTable?"

Опции индекса, используемые методом AddIndex компонента TTable, чуствительны к типу таблицы. Для примера, опция ixUnique работает с таблицами dBASE, но не с таблицами Paradox. Следующая табличка показывает какие опции могут быть применены к каким таблицам (dBASE или Paradox).

    Опции индекса          dBASE    Paradox
    ---------------------------------------
    ixUnique               *
    ixDescending           *        *
    ixNonMaintained        *        *
    ixPrimary                       *
    ixCaseInsensitive               *
"Как мне определить номер записи набора данных?"

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

Приведенная ниже функция в качестве параметра берет любой компонент, производный от TDataset (например, TTable, TQuery, TStoredProc) и возвращает номер текущей записи (больший чем ноль), если это таблица Paradox или dBASE. В противном случае функция возвращает ноль.

Примечание: для таблиц dBASE функция всегда возвращает физический номер записи. Так, если ваш набор данных - TQuery, или вами в наборе данных установлен диапазон (фильтр), то возвращаемый номер записи не обязательно может относиться к заданному набору данных, а может отражать физическое расположение записи в таблице dBASE.

uses DbiProcs, DbiTypes, DBConsts;

function RecordNumber(Dataset: TDataset): Longint;
var
CursorProps: CurProps;
RecordProps: RECProps;
begin
{ Возвращает 0, если набор данных связан не с Paradox или dBASE }
Result := 0;

with Dataset do
begin
{ набор данных активен? }
if State = dsInactive then DBError(SDataSetClosed);

{ Данный вызов необходим для получения курсора iSeqNums }
Check(DbiGetCursorProps(Handle, CursorProps));

{ Синхронизируем курсор BDE с курсором Dataset }
UpdateCursorPos;

{ Заполняем RecordProps свойствами текущей записи }
Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));

{ какого типа наш набор данных? }
case CursorProps.iSeqNums of
0: Result := RecordProps.iPhyRecNum;  { dBASE   }
1: Result := RecordProps.iSeqNum;     { Paradox }
end;
end;
end;

"При редактировании записи я получаю сообщение DBEngine, гласящее "Multiple records found but only one expected" (обнаружены многичисленные записи в то время как ожидалась одна). Что это значит?

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

"Мой опыт обращения к данным Microsoft Access через Delphi-компоненту TTable успешным не назовешь. Используя TQuery я смог получить для работы только вид с флажком "только для чтения", но вид с возможностью чтения/записи получить не удалось. После диалога авторизации я получил сообщение об исключительной ситуации типа 'Passthrough SQL connection must be shared'."

Используйте Database Engine Configuration для изменения опции 'SQLPASSTHRU MODE' в псевдониме, связанным с вашей базой данных Access, из пустого значения по умолчанию на 'SHARED AUTOCOMMIT' (без кавычек).

"Как узнать, что текущая запись в наборе данных изменилась?"

Проверьте в обработчике события OnDataChanged компонента DataSource значение свойства State. В случае изменения текущей записи свойство State будет иметь значение dsBrowse. Следующий пример выводит информационное окошко при каждом изменении записи в источнике данных MyDataSource:

procedure TMyForm.MyDataSourceDataChange(Sender: TObject; Field: TField);
begin
if (Sender as TDataSource).State = dsBrowse then
ShowMessage('Позиция записи изменилась');
end;

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

NewTable.IndexDefs.Assign(Table1.IndexDefs)
?

Вы правильно передали определение индекса в NewTable, но тем не менее свойство IndexDefs Table1 следует обновить, для этого существует метод Update, как им пользоваться видно из примера:

with NewTable do begin
Active := False;
DatabaseName := 'DBDEMOS';
TableName := 'Temp';
TableType := ttParadox;
FieldDefs.Assign(Table1.FieldDefs);
Table1.IndexDefs.Update;             { В первую очередь обновляем }
IndexDefs.Assign(Table1.IndexDefs);
CreateTable;
end;
[000582]


Delphi 1

FAQ 7, Объектный паскаль

Список вопросов
------------------------------

  1. Я использую форму из репозитория и при компиляции получаю ошибку 'unknown identifier' (неизвестный идентификатор). В чем дело?
  2. Могу ли я пользоваться стандартным выводом writeln?
  3. Как мне преобразовать число с плавающей точкой (например, имеющее тип real) в целое?
  4. Как мне сделать так, чтобы при нажатии пользователем клавиши <enter> управление передавалось бы следующему элементу управления, как это происходит при нажатиях клавиши Tab? (Примечание: Это не будет работать в DBGrid, поскольку очередное поле не является отдельным объектом.)
  5. Как в компоненте DBGrid использовать клавишу Enter вместо клавиши Tab?
  6. Как мне обработать параметры командной строки в Delphi-приложении?
  7. Как мне выбрать определенное поле TDBGrid для получения фокуса?
  8. У меня есть таблица paradox с паролем. Что мне необходимо сделать, чтобы форма, использующая эту таблицу, не запрашивала у пользователя пароль?
  9. Как мне сделать форму, не зависящую от разрешения экрана?
  10. Как можно производить вычисления с датой в калькулируемых полях?
  11. Как с помощью Delphi вычислить экспоненту?
  12. Как при запуске приложения сворачивать форму в иконку?
  13. У меня есть форма, которая, в своем роде, шаблон. Я хочу использовать форму несколько раз, но выводя каждый раз разные данные. Каким образом мне можно находить и изменять свойства расположенных на ней компонентов?
  14. Как определить класс компонента, при щелчке на котором появляется контекстное меню?
  15. Как мне захватить и обработать системное сообщение перед тем как выполнится моя строка application.run?
  16. Как мне использовать оператор case для определения того, какой объект вызвал данную процедуру?
  17. Существует ли функция прокрутки формы с помощью клавиш? Например, прокрутка вверх и вниз при нажатии PgUp и PgDown соответственно. Существует простое решение или необходимо перехватывать клавиши и реагировать на них вручную?
  18. Как мне передать тект компонента TMemo в поле TMemofield таблицы Paradox?
  19. Как мне из таблицы сделать таблицу с ASCII текстом фиксированной длины?
  20. Как мне установить формат для поля данных?
  21. Как мне отформатировать число так, чтобы запятая отделяла тысячи?
  22. У меня есть функция, сильно загружающая процессор. Я хочу организовать проверку того, не нажал ли пользователь кнопку отмены? Как мне сделать это, если в это время окно "зависает"?
  23. Как мне получить наибольший и наименьший байт слова? А как осуществить вставку?
  24. У меня есть OBJ-файл, где скомпилированы несколько ассемблерных программ. Я не хотел бы их снова перезаписывать. Есть какой-либо способ использовать этот файл в приложении Delphi?
  25. Какую модель памяти использует Delphi?
  26. Как мне быть, если компонент не обрабатывает системное сообщение?
  27. Borland решил, что доступ к переменным среды из программ Windows это плохо. Я хотя бы могу воспользоваться "устаревшим" модулем WinDos?
  28. Как мне создать простейший хранитель экрана (например, черный экран) с помощью Delphi?
  29. Как мне определить длину строки в пикселах с определенным шрифтом?
  30. Какое наилучшее место в коде программы, откуда можно вызвать окно с логотипом программы при ее запуске?
  31. Как вызвать функцию из DLL?
  32. Что такое функция Callback и как мне создать ее?
Вопросы и ответы
---------------------
  1. Я использую форму из репозитория и при компиляции получаю ошибку 'unknown identifier' (неизвестный идентификатор). В чем дело?

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

  2. Могу ли я пользоваться стандартным выводом writeln?

    Включите WinCRT в список используемых модулей и пользуйтесь на здоровье.

  3. Как мне преобразовать число с плавающей точкой (например, имеющее тип real) в целое?

    Вот пара методов:

    var
    i: integer;
    r: real;

    begin
    r := 34.56;
    i := trunc(r);  {i = 34}  {Первый метод}
    i := round(r);  {i = 35}  {Второй метод}
    end;

  4. Как мне сделать так, чтобы при нажатии пользователем клавиши <enter> управление передавалось бы следующему элементу управления, как это происходит при нажатиях клавиши Tab? (Примечание: Это не будет работать в DBGrid, поскольку очередное поле не является отдельным объектом.)

    Вам необходимо перехватывать нажатие клавиши и устанавливать ваш собственный ответ на это. Попробуйте:

    procedure TMainForm.FormCreate(Sender: TObject);
    begin
    keyPreview := true; {"Включаем" обработку.}
    end;

    procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
    begin
    if Key = #13 then
    begin
    Key := #0;
    PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
    end;
    end;

  5. Как в компоненте DBGrid использовать клавишу Enter вместо клавиши Tab?

    Действие клавиши Tab происходит после возникновения события OnKeyDown, а клавиша Enter "действует" уже в OnKeyPress. Следовательно, клавиша Enter должна приниматься во внимание в обоих обработчиках для достижения желаемого эффекта. Попробуйте:

    procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift:
    TShiftState);
    begin
    if Key = VK_RETURN then Key = VK_TAB;
    end;

    procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
    begin
    if Key = #13 then Key := #9;
    end;

  6. Как мне обработать параметры командной строки в Delphi-приложении?

    Пользуйтесь методами ParamCount и ParamString.

  7. Как мне выбрать определенное поле TDBGrid для получения фокуса?

    Используйте следующий код:

    DBGrid1.SelectedField := Table1SomeField;
    DBGrid1.SetFocus;

  8. У меня есть таблица paradox с паролем. Что мне необходимо сделать, чтобы форма, использующая эту таблицу, не запрашивала у пользователя пароль?

    Установите в компоненте Table свойство ACTIVE в FALSE. Разместите следующий код в обработчике создания формы:

    session.AddPassword('Мой секретный пароль');
    table1.active := true;

  9. Как мне сделать форму, не зависящую от разрешения экрана?

    Вот некоторый код, показывающий как это можно сделать:

    const
    ScreenHeight: Integer = 800; {Я разрабатывал мою форму в режиме 800x600.}
    ScreenWidth: Integer = 600;

    procedure TForm1.FormCreate(Sender: TObject);
    var
    x, y: LongInt; {Целое не будет достаточной для этого величиной.}

    begin
    form1.scaled := true;
    x := getSystemMetrics(SM_CXSCREEN);
    y := getSystemMetrics(SM_CYSCREEN);
    if (x <> ScreenHeight) or (y <> ScreenWidth) then
    begin
    form1.height := form1.height * x DIV ScreenHeight;
    form1.width := form1.width * y DIV ScreenWidth;
    scaleBy(x, ScreenHeight);
    end;
    end;

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

  10. Как можно производить вычисления с датой в калькулируемых полях?

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

    В приведенном ниже методе d1 и d2 (часть table1) могут быть или датой (date) или иметь тип dateTime, d3 - целочисленное поле.

    procedure TForm1.Table1CalcFields(DataSet: TDataset);
    var
    t1, t2: tDateTime;
    begin
    table1d1.asDateTime := Date + 2; {или table1d1.value := date + 2;}
    table1d2.asDateTime := Date - 2;
    t1 := table1d1.asDateTime;
    t2 := table1d2.asDateTime;
    table1d3.asInteger := trunc(double(t1) - double(t2));
    end;

  11. Как с помощью Delphi вычислить экспоненту?

    Для ExpXY(X, Y) (например, Y^X), попробуйте:

    ExpXY := Exp(Y * Ln(X))

    Для использования функции объявите формальные параметры и результат функции как Extended, преобразование фактических параметров и возвращаемого функцией результата происходит автоматически. (Примечание: Ln - натуральный логарифм числа).

  12. Как при запуске приложения сворачивать форму в иконку?

    В секции private класса формы поместите:

    PROCEDURE WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN;

    В секции implementation создайте реализацию метода:

    PROCEDURE TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen);
    begin
    Msg.Result := 0;
    end;

    Это все! Форма всегда будет в виде иконки. BTW, естественно, вы при этом вы должны установить свойство формы WindowState в wsMinimized.

  13. У меня есть форма, которая, в своем роде, шаблон. Я хочу использовать форму несколько раз, но выводя каждый раз разные данные. Каким образом мне можно находить и изменять свойства расположенных на ней компонентов?

    К примеру, создадим независимое окно:

    with TMyForm.create(self) do show;

    Теперь нам нужно управлять этим. Вот один из способов изменения заголовка каждой созданной формы. Осуществим это через массив компонентов формы. В качестве другой формы данный пример использует диалоговое окно "О программе" (с именем "box").

    procedure TForm1.Button1Click(Sender: TObject);

    begin
    with tBox.create(self) do show;
    {Необходимо ComponentCount-1 поскольку отсчет идет с нуля}
    (form1.Components[form1.ComponentCount-1] as tForm).caption :=
    'About Box # ' + intToStr(form1.ComponentCount-2);
    end;

  14. Как определить класс компонента, при щелчке на котором появляется контекстное меню?

    Используйте свойство PopupComponent компонента PopupMenu для определения компонента, на котором была нажата правая клавиша мыши.

    procedure TForm1.PopupItem1Click(Sender: TObject);
    begin
    Label1.Caption := PopupMenu1.PopupComponent.ClassName;
    end;

    Можно использовать свойство формы ActiveControl, но компонент, вызвавший контекстное меню, не обязательно должен быть активным элементом управления.

  15. Как мне захватить и обработать системное сообщение перед тем как выполнится моя строка application.run?

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

    program Project1;

    uses
    Forms, messages, wintypes, winprocs,
    Unit1 in 'UNIT1.PAS' {Form1};

    {$R *.RES}

    var
    OldWndProc: TFarProc;

    function NewWndProc(hWndAppl: HWnd; Msg, wParam: Word;
    lParam: Longint): Longint; export;
    begin
    result := 0; { Значение, возвращаемое WndProc по умолчанию }
    {*** Здесь дескриптор сообщения; Номер сообщения в Msg ***}
    result := CallWindowProc(OldWndProc, hWndAppl, Msg, wParam, lParam);
    end;

    begin
    Application.CreateForm(TForm1, Form1);
    OldWndProc := TFarProc(GetWindowLong(Application.Handle,
    GWL_WNDPROC));
    SetWindowLong(Application.Handle, GWL_WNDPROC,
    longint(@NewWndProc));
    Application.Run;
    end.

  16. Как мне использовать оператор case для определения того, какой объект вызвал данную процедуру?

    Используйте свойство объекта TAG. Для группирования объектов по определенным признакам вы можете установить значение свойства tag каждого объекта. (Идеальным было бы использование констант, описывающих объект.)

    Примечание: код подразумевает, что только tButton может вызвать эту процедуру.

    case (sender as tButton).tag of
    0:  blah;
    1:  blah_blah;
    end;

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

    Прокрутка формы осуществляется с помощью изменения свойства Position свойства формы VertScrollbar или HorzScrollbar. Следующий код показывает как это можно сделать:

    procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
    Shift: TShiftState);
    const
    PageDelta = 10;
    begin
    With VertScrollbar do
    if Key = vk_Next then  Position := Position+PageDelta
    else if Key = vk_Prior then Position := Position-PageDelta;
    end;

  18. Как мне передать тект компонента TMemo в поле TMemofield таблицы Paradox?

    Вот пример:

    procedure TForm1.Button1Click(Sender: TObject);
    var
    t: TTable;
    begin
    t := TTable.create(self);
    with t do
    begin
    DatabaseName := 'MyAlias'; {персональный псевдоним}
    TableName := 'MyTbl.db';
    open;
    edit;
    insert;
    fieldByName('TheField').assign(memo1.lines); {Вот оно!}
    post; {требуется!!!}
    close;
    end;  { Конец with-блока. }
    end;

  19. Как мне из таблицы сделать таблицу с ASCII текстом фиксированной длины?

    Можно так:

    procedure TForm1.Button1Click(Sender: TObject);
    var
    t1, t2: tTable;  {t1 = PW таблица; t2 = ASCII версия}
    begin
    t1 := tTable.create(self);
    with t1 do
    begin
    DataBaseName := 'pw'; { Персональный псевдоним для каталога Paradox }
    tableName := 'customer.db'; { Исходная таблица }
    open;
    end;
    t2 := tTable.create(self);
    with t2 do
    begin
    DataBaseName := 'pw'; { Персональный псевдоним для каталога Paradox }
    tableName := 'asdf.txt';
    TableType := ttASCII;

    createTable;
    open;
    edit;
    BatchMove(t1, batCopy);
    close;
    end;
    t1.close;
    end;

  20. Как мне установить формат для поля данных?

    Дважды щелкните на компоненте Table. Выберите поле, которое вы хотите форматировать. Далее воспользуйтесь свойствами DisplayFormat и EditFormat. DisplayFormat работает когда поле не имеет фокуса. EditFormat работает когда поле имеет фокус. Пользуйтесь теми же командами, что и для первого параметра функции FormatFloat, только без кавычек.

  21. Как мне отформатировать число так, чтобы запятая отделяла тысячи?

    Если вы не используете Delphi, попробуйте следующий код:

    function FormatNumber(l: longint): string;
    var
    len, count: integer;
    s: string;
    begin
    str(l, s);
    len := length(s);
    for count := ((len - 1) div 3) downto 1 do
    begin
    insert(',', s, len - (count * 3) + 1);
    len := len + 1;
    end;
    FormatNumber := s;
    end;

    Если вы пользуетесь Delphi, то, естественно, существует более простое решение:

    function FormatNumber(l: longint): string;

    begin
    FormatNumber := FormatFloat('#,##0', StrToFloat(IntToStr(l)));
    end;

  22. У меня есть функция, сильно загружающая процессор. Я хочу организовать проверку того, не нажал ли пользователь кнопку отмены? Как мне сделать это, если в это время окно "зависает"?

    Время от времени производите в вашем коде вызов процедуры Application.ProcessMessages.

  23. Как мне получить наибольший и наименьший байт слова? А как осуществить вставку?

    Существуют встроенные методы hi() и lo(), но если вы хотите знать как это делается и попытаться сделать по-другому... (хотя вряд ли вы сможете увеличить быстродействие <G>). Функция для вставки в Delphi отсутствует.

    Примечание: Функции ассемблера возвращают содержимое регистра AX.

    function GetHiByte(w: word): byte; assembler;
    asm
    mov ax, w
    shr ax, 8
    end;

    function GetLoByte(w: word): byte; assembler;
    asm
    mov ax, w
    end;

    function SetHiByte(b: byte; w: word): word; assembler;
    asm
    xor ax, ax
    mov ax, w
    mov ah, b
    end;

    function SetLoByte(b: byte; w: word): word; assembler;
    asm
    xor ax, ax
    mov ax, w
    mov al, b
    end;

    Другой путь сделать это (с примером использования):

    Type
    TWord2Byte = record
    Lo,Hi: Byte;
    end;

    var W: Word;
    B: Byte;
    begin
    W := $1234;
    B := TWord2Byte(W).Hi;
    writeln(TWord2Byte(W).Hi);
    { возвращаем }
    TWord2Byte(W).Lo := $67;
    TWord2Byte(W).Hi := $98; { shl не нужен! }
    end.

  24. У меня есть OBJ-файл, где скомпилированы несколько ассемблерных программ. Я не хотел бы их снова перезаписывать. Есть какой-либо способ использовать этот файл в приложении Delphi?

    Вы не указали, должны ли возвращаться значения или нет (в Pascal это важно.)

    Если нет, сделайте такое объявление:

    Procedure TurnOn;  External;
    Procedure TurnOff; External;

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

    Function TurnOn: Integer; External;
    Function TurnOff: Integer; External;

    Замените Integer возвращаемым типом данных. В любом случае вам необходимо прилинковать ваш OBJ-файл:

    {$L filename.obj}

    Смотрите также в электронной справке раздел "linking external assembler code".

  25. Какую модель памяти использует Delphi?

    Delphi использует смешанную модель памяти, но это очень близко к большой модели "C". Установки по умолчанию:

    • Модель дальнего вызова методов
    • Процедуры в секции интерфейса также используют модель дальнего вызова
    • Только используемые процедуры в секции реализации имеют модель ближнего вызова
    • Данные кучи и все указатели (включая экземпляры класса) в основном пользуются модель дальнего вызова
    • Глобальные переменные - ближний вызов (DS based)
    • Процедурные параметры и локальные переменные - ближний вызов (SS based)
    • Процедуры объявленные как FAR или EXPORT используют дальний вызов
    • Таблицы виртуальной памяти - дальний вызов для новой модели класса и ближний для старой

    Данная схема используется в Borland Pascal уже долгое время. Я нахожу это гибким и эффективным.

    Именно поэтому все public-процедуры, методы и указатели уже готовы к эксплуатации на 32-битных платформах, Delphi32 не должна в них ничего менять. Похоже, Delphi32 также переключится на 32-битную адресацию данных и сегментов стека, что также не должно повлиять на ваши программы. Все, что может повлиять - изменение разрядности целого с 16 на 32 бита.

  26. Как мне быть, если компонент не обрабатывает системное сообщение?

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

    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

    В секции реализации все происходит примерно так:

    procedure TWhateverComponent.WMPaint(var Message: TWMPaint);
    begin
    {Теперь заставьте ваш компонент реагировать на событие должным образом}
    end;

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

  27. Borland решил, что доступ к переменным среды из программ Windows это плохо. Я хотя бы могу воспользоваться "устаревшим" модулем WinDos?

    Используйте API-вызов GetDOSEnvironment().

  28. Как мне создать простейший хранитель экрана (например, черный экран) с помощью Delphi?

    Вот простейшая реализация хранителя экрана:

    var
    f: tForm;

    begin
    f := tForm.create(self);
    f.WindowState := wsMaximized;
    f.color := black;
    f.borderStyle := bsNone;
    f.show;
    end;

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

  29. Как мне определить длину строки в пикселах с определенным шрифтом?

    Для определения высоты и ширины строки в пикселах могут применяться два метода - TextHeigh и TextWidth. Данные методы могут быть доступны в компонентах, имеющих свойство Canvas, например, TForm. Компонент TPanel не имеет доступа к свойству Canvas, т.к. по умолчанию оно защищено (protected).

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

    function GetTextWidth(CanvasOWner: TForm; Text : String;
    TextFont :  TFont): Integer;
    var
    OldFont : TFont;
    begin
    OldFont := TFont.Create;
    try
    OldFont.Assign( CanvasOWner.Font );
    CanvasOWner.Font.Assign( TextFont );
    Result := CanvasOWner.Canvas.TextWidth(Text);
    CanvasOWner.Font.Assign( OldFont );
    finally
    OldFont.Free;
    end;
    end;

  30. Какое наилучшее место в коде программы, откуда можно вызвать окно с логотипом программы при ее запуске?

    Наилучшее место для показа окна с логотипом - в исходном коде проекта после первого FormCreate и перед Run. Этим мы осуществляем создание формы на лету и показ ее до момента фактического запуска приложения.

    program Project1;

    uses Forms,  Unit1 in 'UNIT1.PAS' {Form1}, Splash;

    {$R *.RES}
    var
    SplashScreen : TSplashScreen; {в модуле Splash}

    begin
    Application.CreateForm(TForm1, Form1);
    SplashScreen := TSplashScreen.Create(Application);
    try
    SplashScreen.Show;
    {
    осуществите остальные CreatForms или другие
    действия прежде чем приложение запустится
    }
    SplashScreen.Close;
    finally  {Убедитесь что окно с логотипом освобождается}
    SplashScreen.Free;
    end;
    Application.Run;
    end.

  31. Как вызвать функцию из DLL?

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

    procedure TForm1.Button1Click(Sender: TObject);

    type
    TCallMeDll = function(a,b: Integer): string;

    var
    CallMeDll: TCallMeDll;
    FuncPtr: TFarProc;
    hDll: THandle;
    result: string;

    begin
    hDll:=LoadLibrary('Mytestdll.dll');
    FuncPtr:=GetProcAddress(hDLL,'CallMe');
    @CallMeDll:=FuncPtr;
    if @CallMeDll <> nil then
    result:=CallMeDll(4,5);
    FuncPtr:=nil;
    FreeLibrary(hDll);
    end;

    Обратите внимание на порядок действий: сначала мы нагружаем dll в память, затем получаем указатель на функцию, и затем назначаем его CallMeDll. В этой точке необходимо проверить, если ProcAdderss равен Nil, то вызов GetProcAddress был неудачным.

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

  32. Что такое функция Callback и как мне создать ее?

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

    { В интерфейсе программы }

    type
    TCallBackFunction = function(s: string): integer;
    CallMe(s: string): integer;

    И в секции реализации:

    { Программная реализация }

    procedure TestCallBack(CallBackFunction: TCallBackFunction); far; external 'Other';
    { Имейте в виду, что 'other' - размещенная в Dll процедура с именем TestCallBack }

    function CallMe(s: PChar): integer;
    begin
    { сделайте что-нибудь }
    CallMe := 1; { сделайте что-нибудь }
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    TestCallBack(CallMe);
    end;

    Имейте в виду, что в 'Other' вы должны также объявить и использовать функциональный тип, например так:

    { в интерфейсе библиотеки Other }

    type
    TMainFunction = function(s: string): integer;
    TestCallBack(MainFunc: TMainFunction);

    { в реализации библиотеки Other }

    TestCallBack(MainFunc: TMainFunction);
    var
    result: integer;
    begin
    result:=MainFunc('тест');
    end;

    [000583]


Delphi 1

FAQ 8 VBX

"Какие файлы мне необходимо распространять вместе с моим приложением, если в своих формах я использую VBX?"

Лицензия Delphi позволяет распространять BIVBX11.DLL (расположенную в директории \Windows\System), требующуюся при использовании VBX. Другая необходимая вещь - лицензия на распространение VBX, получаемая от поставщика VBX. И, конечно, сам VBX и связанные с ним файлы.

"Мой VBX не загружается или "сваливает" Delphi после при попытке его загрузить. В чем дело?"

Наиболее вероятно, что вы пытаетесь использовать VBX, совместимый с Visual Basic 2.0 или 3.0. Delphi может использовать VBX, совместимый только с VB 1.0.

"Поставщик используемого мною VBX сказал мне, что его VBX определяет установленную в системе версию VB и сам контролирует и правильно распознает вызовы к различным версиям VB так, что это будет одинаково работать как с VB 2.0, так и с 3.0. Почему у меня это не работает?"

Для некоторых VBX это работает, для некоторых нет. Приносим свои извинения за этот ответ, сейчас мы выясняем причину этой ошибки и чуть позже проинформируем вас. В данный момент, если ваш VBX не загружается, вы можете: а) не использовать его или б) создать для вашего компонента обертку для работы с вызовами версий 2.0 и 3.0.

"После установки Delphi несколько VB-приложений перестали работать. Как теперь быть?"

Из файла INSTALL.TXT, расположенного в каталоге ..\DELPHI:

     __________________________________________________________
     |
     |  2. ПРЕЖДЕ ЧЕМ ВЫ ЗАПУСТИТЕ УСТАНОВКУ (SETUP)
     |  -----------------------
     |  .
     |  .
     |  .
     |  o Элементы управления VBX - SETUP устанавливает следующие
     |    файлы VBX в каталог \WINDOWS\SYSTEM и перезаписывает
     |    любые существующие файлы VBX с теми же именами:
     |
     |      GAUGE.VBX
     |      SWITCH.VBX
     |      PICT.VBX
     |      CHART2FX.VBX
     |
     |    Перед установкой проверьте наличие файлов с этими
     |    именами и при необходимости создайте их копии.
     |
     |  .
     |  .
     |  .
     |  _______________________________________________________
Оригинальные файлы, которые, возможно, были перезаписаны, могли быть частью вашего VB-приложения. Если причина в этом, необходимо осуществить следующие шаги (приведен пример для файла GAUGE.VBX):
  1. Загрузите Delphi и удалите GAUGE.VBX из Палитры компонентов:
    1. Выберите пункт меню Options | Install Components.
    2. Выберите GAUGE из списка установленных модулей (Installed Units).
    3. Щелкните на кнопку REMOVE (модуль исчезнет из списка).
    4. Щелкните на кнопку OK. Delphi перекомпилит библиотеку компонентов.
    5. Закройте Delphi.
  2. В File Manager переименуйте файл GAUGE.VBX в файл с именем, например, BIGAUGE.VBX.
  3. Снова загрузите Delphi и добавьте BIGAUGE.VBX в Палитру компонентов:
    1. Выберите пункт меню Options | Install Components.
    2. Щелкните на кнопку VBX.
    3. Выберите необходимый VBX (в нашем случае BIGAUGE.VBX).
    4. Щелкните на кнопку OK с диалоговом окне "Install VBX File".
    5. Щелкните на кнопку OK с диалоговом окне "Install Components". Delphi перекомпилит библиотеку компонентов.
  4. Скопируйте VBX (GAUGE.VBX), используемое вашим VB-приложением, в каталог \Windows\System directory.
Это должно решить проблемы с конфликтами файлов.

"После установки Delphi, каждый раз при запуске приложения компании NetCom NetCruiser (являющегося VB-приложением), возникает надпись 'NETCRUZ An error has occurred in your application. If you choose ignore..' (NETCRUZ: В вашем приложении произошла ошибка. Если вы выберите игнорировать...). Что случилось?"

Delphi установил "GAUGE.VBX" поверх родного VB. Установленный Delphi файл несовместим со своей VB-версией (Смотри выше Q&A). [000584]


Delphi 1

FAQ 9, Компоненты

"Могу ли я пользоваться исходным кодом VCL?"

Если вам интересен процесс создания новых компонентов, тогда да, стопроцентное ДА! Имея исходный код VCL, вы можете изучить и понять принцип создания компонентов VCL вплоть до секций private. Это окажет неоценимую помощь при создании собственных компонентов. Также вы будете иметь возможность пройтись по исходному коду компонент с помощью отладчика.

"По вашему совету я приобрел исходный код VCL, но почему я не нашел там исходный код для "tab"-элементов управления (например, TTabbedNotebook и др.)?"

Исходный код VCL не содержит код "tab"-компонентов из-за юридических причин. Тем не менее, исходники интерфейса (interface source) расположены в каталоге DELPHI\DOC и имеют расширение INT.

Примечание: зарегистрированные владельцы исходного кода Delphi RTL могу запросить исходный код TTabSet и TTabbedNotebook у подразделения Borland Corporate Affairs, контактное лицо Karen Rogers, факс (US) 408-431-4171.

"Я пытаюсь создать свой собственный компонент, но я не знаю от кого мне нужно наследоваться."

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

   TComponent      - Базовая отправная точка для невизуальных компонентов.
   TWinControl     - Базовая отправная точка для компонентов, которым необходимо
                     иметь оконный дескриптор.
   TGraphicControl - Хорошая отправная точка для компонентов, которым не нужен
                     дескриптор окна. Данный класс имеет метод Paint,
                     который должен быть перекрыт, но не имеет холста.
   TCustomControl  - Наиболее удачная отправная точка для визуальных компонентов.
                     Данный класс имеет дескриптор окна, общий набор событий и
                     свойств и, что наиболее важно, хост и метод Paint().
"Как мне переписать для моего приложения обработчик сообщения по умолчанию?"

Создайте динамический метод, индексирующий константу сообщения, которую вы хотите перекрыть. Например, если вы хотите перекрыть сообщение CM_DIALOGKEY, объявите следующую процедуру в секции public объявлений класса:

Procedure CMDialogKey(var Message: TCMDialogKey);message CM_DIALOGKEY;

Это распространенная практика - объявление имени процедуры такой же, как и имя сообщения минус символ подчеркивания. Ваш обработчик сообщения должен выглядеть примерно так:

Procedure TForm1.CMDialogKey(var Message: TCMDialogKey);
begin
if CharCode = VK_TAB then begin
{Здесь обрабатываем нажатие Alt+Tab}
result := 1;
exit;
end;
inherited;
end;

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

"Какое наилучшее место в коде программы, откуда можно вызвать окно с логотипом программы при ее запуске?"

Наилучшее место для показа окна с логотипом - в исходном коде проекта после первого FormCreate и перед Run. Этим мы осуществляем создание формы на лету и показ ее до момента фактического запуска приложения.

program Project1;

uses Forms,  Unit1 in 'UNIT1.PAS' {Form1}, Splash;

{$R *.RES}
var
SplashScreen : TSplashScreen; {в модуле Splash}

begin
Application.CreateForm(TForm1, Form1);
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
{
осуществите остальные CreatForms или другие
действия прежде чем приложение запустится
}
SplashScreen.Close;
finally  {Убедитесь что окно с логотипом освобождается}
SplashScreen.Free;
end;
Application.Run;
end.

"Какой порядок возникновения событий при создании формы и ее показе?"

При создании формы события происходят в следующем порядке: OnCreate, OnShow, OnPaint, OnActivate, OnResize и снова OnPaint.

"Почему моя программа не может найти ресурсы, упакованные мной в .RES-файл, если .RES-файл имеет то же самое имя, что и модуль формы?"

Если имя используемого вами .RES-файла совпадает с именем .DPR-файла, Delphi перезапишет его, создав собственный .RES-файл с этим именем.

"Я унаследовался от компонента TPanel. Я вижу, что в конструкторе присутствует свойство BevelWidth; его значение всегда равно 1 независимо от того, что установил пользователь в режиме проектирования. Очевидно, значение свойства изменяется в режиме проектирования где-то после того, как "сработает" конструктор. Где это происходит? Где лучшее место для перехвата этого значения при инициализации компонента?"

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

"Я пытаюсь опубликовать свойство массива, но получаю ошибку #202, говорящую о том, что свойство не может быть опубликовано. Я думал что свойство, имеющее редактор, можно опубликовать.

Обратитесь в раздел электронной справки "published parts", где вы можете увидеть, какие свойства и поля могут быть опубликованы, а какие нет. Для того, чтобы нестандартные типы данных (к которым относятся свойства массива) могли работать с потоком, перекройте унаследованный метод компонента DefineProperties для регистрации авторской реализации механизма чтения и записи свойства. Для примера посмотрите исходный код TStringList - там используется DefineProperties для регистрации собственного "читателя" и "писателя" для обработки потока строк в собственном списке.

"Я создаю компонент во время выполнения приложения, но объявленные значения по умолчанию ("default") почему-то не работают. Почему?"

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

[000585]


Delphi 1

FAQ 14 - Windows API

Данный документ содержит информацию, которая чаще всего востребуется пользователями данной темы. Перечень доступных тем, список документов Technical Information Documents и сами документы свободны для загрузки в секции технической библиотеки сайта компании Borland.

"Каким образом я могу включить или выключить конкретный элемент управления в диалоговом окне?"

Используйте функцию API EnableWindow(Wnd: Hwnd, Enable: Bool). Ей необходимо передать два параметра - дескриптор окна (помните, что элемент управления является окном), которое необходимо включить/выключить (enabled/disabled) и логическую величину - True для включения и False для выключения.

"Как мне получить дескриптор или ID элемента управления?"

Если вы имеете указатель на объект, OWL позволит автоматически получить дескриптор окна посредством поля HWindow; PointerToMyControl^.HWindow - дескриптор окна.

Если вы знаете дескриптор элемента управления, ID можно получить, вызвав функцию API GetDlgCtrlID():

ControlID := GetDlgCtrlID(ControlHandle);

Если у вас нет указателя на элемент управления, зато есть ID, вы можете получить его дескриптор с помощью API функции GetDlgItem():

ControlHandle := GetDlgItem(DialogHandle, ControlID);

"Как мне выгрузить DLL-ки ненормально прерванных программ?"

C помощью GetModuleHandle вы можете получить дескрипторы dll-к, вызывайте freelibrary до тех пор, пока GetModuleHandle не возвратит 0. Если dll загружало при этом другую dll, выгрузите "ребенка" в первую очередь.

"Как мне спрятать минимизированную иконку без изъятия программы из списка задач?"

Переместите иконку за пределы экрана с помощью SetWindowPos или MoveWindow, задав иконке отрицательные координаты.

"Как мне изменить сегмент данных dll с фиксированного на перемещаемый?"

Вызовите GlobalPageUnloch(DSEG) во внешнем блоке вашей dll. Это будет работать, заставляя dll не содержать код, требуемый для блокирования страницы сегмента данных. [000586]


Delphi 1

FAQ 15 - Отладка/Утилиты

Данный документ содержит информацию, которая чаще всего востребуется пользователями данной темы. Перечень доступных тем, список документов Technical Information Documents и сами документы свободны для загрузки в секции технической библиотеки сайта компании Borland.

Смотрите также:

TI1037 Настройка/Использование Turbo Debugger for Windows
TI1262 Замечания относительно установки Turbo Debugger for Windows
TI1171 Форма рапорта Borland о проблеме

"Как мне хранить мои Resource Workshop проекты - как .RES- или как .RC-фалы?"

С тех пор как .RC-файлы стали представлять собой ASCII-текст, их стало легче отлаживать и делить с другими программистами, поэтому лучше хранить ваш проект в виде .RC-файла, на основе которого автоматически создается .RES-файл. Для этого сначала создайте .RC-проект. Затем выберите File|Preferences и поставьте галочку напротив "Multi-Save .RES file." Теперь, при каждом сохранении вашего проекта .RES-файл будет создаваться автоматически.

"Что такое WinSpector и WinSight?"

WinSpector - утилита, позволяющая выполнять "посмертный" анализ приложения, разрушевшегося в результате General Protection Fault (ошибка общей защиты, GPF) или Unrecoverable Application Error (неисправимая ошибка приложения). WinSpector может вам показать:

  • Содержимое стека.
  • Имена функций и процедур в содержимом стека (с вашей небольшой помощью).
  • Регистры CPU.
  • Дизассемблирование инструкций.
  • Системная информация.
WinSight - утилита, дающая информацию относительно классов window, окон и сообщений выполняющихся приложений. С помощью нее можно увидеть как любое приложение создает экземпляры классов и окон, как окна посылают и получают сообщения.

"Почему, когда я запускаю Turbo Debugger for Windows, мой экран становится пустым или наблюдается буйство красок?"

Turbo Debugger video DLL, которую вы используете, очевидно несовместима с вашим видео-драйвером Windows. Загрузите TDSVGA.ZIP из library 2 и попытайтесь заменить TDWGUI.DLL или TDSVGA.DLL. Следуйте за инструкциями файла "readme".

"У меня имеется достаточно большое приложение, и оно почему-то некорректно работает в Turbo Debugger for Windows и Turbo Profiler for Windows. В чем проблема?"

Turbo Debugger for Windows и Turbo Profiler for Windows имеют ограничения по размеру файлов и количеству обрабатываемых символов. Если вы оказались в описанной выше ситуации, то лучший выход из сложившейся ситуации - разделение проекта на отдельные логические единицы для их последующей индивидуальной отладки.

"Я только что установил Borland C++ 4.0 и у меня есть TPW 1.5 и BP 7.0. Почему после этого у меня появились проблемы с корректной работой Pascal Turbo Debugger for Windows?"

Три наиболее частые причины:

  • Убедитесь, что \BP\BIN (или \TPW\BIN) присутствуют в переменной PATH перед \BC4\BIN.
  • Убедитесь, что вы загружаете ту версию TDDEBUG.386 (в секцию [386Enh] файла SYSTEM.INI), которая пришла вместе с Pascal.
  • Переименуйте файл TDW.INI, поставляемый с BC4, для того, чтобы Pascal смог создать свой собственный файл.
Обратитесь к документу TI1037 библиотеки 2. Он содержит дополнительную информацию по TDW. [000587]


Delphi 1

FAQ 20 - Сети

Данный документ содержит информацию, которая чаще всего требуется пользователями данной темы. Перечень доступных тем, список документов Technical Information Documents и сами документы свободны для загрузки в секции технической библиотеки сайта компании Borland.

Смотрите также

TI555    Блокирование файла и записи в Turbo Pascal
TI1201   Установка Turbo Pascal в сети
"Как мне открыть файл в режиме только для чтения?"

Turbo Pascal предоставляет возможность открыть файл в одном из нескольких режимах. Обычно режим файла изменяется после вызова Assign, но перед вызовом Reset или ReWrite. Вы можете сделать изменения, назначая числовые значения внутренней переменой FileMode.

"Какое значение по умолчанию для FileMode? Какие значения необходимы для режима общего чтения/записи и какое для режима только для чтения?"

По умолчанию, FileMode установлено в 2. Установите FileMode в 66, и вы получите режим общего чтения/записи, значение 64 позволит получить режим только для чтения.

"Могу ли я реализовать блокировку файла или записи в моем собственном коде?"

Turbo Pascal не имеет встроенных функций для блокировки файлов и записей, поэтому для выполнения этих операций вам необходимо перейти на уровень ассемблера (или вызовов MsDos/Intr). В DOS версии 3.0 и выше, блокирование файла и записи возможно через прерывание $21, сервис $5C, субфункции 0 и 1. (Смотри TI555 и следующий В/О.).

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

Реально блокировка записи или файла очень сложна в реализации. В результате вышесказанного, стандартной практикой для программистов стало приобретение специализированных продуктов, осуществляющих описанную функциональность и обладающие множеством других возможностей для работы с базами данных, таких, как Borland Database Engine (последний релиз - лето 94), B Tree Filer for Turbo Power, или Paradox Engine.

"Как мне получить доступ к сети и другим сетевым функциям?"

Turbo Pascal не содержит встроенных функций для работы с сетью, кроме вызовов, базирующихся на системных функциях, таких, как WNetAddConnection, WNetCancelConnection или WNetGetConnection. В библиотеке Compuserve в секции 20 (по данным на май 94) имеются различные инструменты и библиотеки для работы с сетью, например, файлы MAPI.ZIP и TPAPI.ZIP.

[000674]


Delphi 1

Детальное описание DELPHI.INI (1 из 2)

Ниже приведено детальное описание всех секций и переменных файла DELPHI.INI. Для сокращения объема статьи были соблюдены несколько соглашений в описаниях возможных значений настроек.

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

MapFile=0|1|2|3
Допускает только значение 0, 1, 2 или 3

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

GridSizeX=[2..128]
допускает любое значение в пределах от 2 до 128, включительно.

Секция: [Globals] - Секция "Globals" содержит настройки, не вошедшие в другие секции и влияющие на работу Delphi в целом. Переменные данной секции могут быть изменены только путем редактирования файла DELPHI.INI.

PrivateDir=
Данная переменная указывает на каталог, где Delphi будет создавать и где будут размещаться файлы DELPHI.DSK, DELPHI.DMT, DEFPROJ.OPT и STDVCS.CFG. Каталог по умолчанию - \DELPHI\BIN. Если Delphi запускается из каталога с флагом "только для чтения" (или с CD-ROM), данная переменная должна указывать на каталог с возможностью записи, на сетевой или локальный. Переменная должна содержать полностью корректный путь, включая букву диска. Пример: PrivateDir=J:\USERS\JSMITH ; Частный сетевой каталог.

HintColor=
Данная переменная отвечает за цвет окна всплывающей подсказки в Delphi IDE. Значение может быть десятичной или шестнадцатиричной константой, или одной из символьных цветовых констант, определенных в VCL (например, clCyan). Имейте в виду, что цвет текста всплывающей подсказки всегда имеет системный цвет clWindowText. Значение по умолчанию clYellow.

PropValueColor=
Данная переменная отвечает за цвет текста (значений) в правой панели Инспектора Объектов. Значение может быть десятичной или шестнадцатиричной константой, или одной из символьных цветовых констант, определенных в VCL (например, clBlue). Значение по умолчанию clWindowText.

Секция: [Library] - Секция "Library" содержит данные для установок страницы Library (библиотека) диалога Environment Options (настройки среды), доступный через меню Options|Environment. Установки данной секции вступают в силу в случае, когда выбрана опция Library меню Options|Rebuild.

SearchPath=
Задает пути поиска для модулей, необходимых компилятору для сборки библиотеки компонентов. Имена путей должны быть указаны последовательно и разделяться точкой с запятой. Значение данной переменной должно изменяться с помощью выпадающего списка 'Library Path'. Пример:

    SearchPath=D:\DELPHI\LIB;d:\delphi\rcexpert
ComponentLibrary=
Определяет имя активной библиотеки компонентов. Данная переменная может быть изменена через пункт меню Options|Open Library. Также она может быть изменена с помощью поля редактирования 'Library filename' (имя файла библиотеки) диалога Install Components (установка компонентов) (доступный через меню Options|Install Components). Пример:
    ComponentLibrary=D:\DELPHI\BIN\REXPERT.DCL
SaveLibrarySource=0|1
Указывает способ сохранения Delphi исходного кода библиотеки компонентов при установке новых или пересборке старых с помощью пункта меню Options|Rebuild Library. Значение 1 указывает на необходимость сохранения исходного кода проекта, используя имя корня файлов библиотеки с расширением .DPR. Значение по умолчанию 0. Данная переменная может быть изменена с помощью CheckBox 'Save library source code' (сохранение исходного кода библиотеки).

MapFile=0|1|2|3
Определяет тип производимого map-файла, если он существует при пересборке библиотеки компонентов. Map-файл располагается в том же каталоге, что и библиотека, и имеет расширение .MAP. Значение по умолчанию 0. Данная переменная изменяется посредством группы радиокнопок 'Map file'.

  Флаг          Эффект
  ------------  ------
  0 - Off       Map-Файл не генерируется.
   (выключено)
  1 - Segments  Компоновщик генерирует map-файл, включающий
   (Сегменты)   список сегментов, стартовый адрес программы
                и любые предупреждения или сообщения об ошибках,
                возникающих во время компоновки.
  2 - Publics   Компоновщик генерирует map-файл, включающий
   (публичный)  список сегментов, стартовый адрес программы,
                любые предупреждения или сообщения об ошибках,
                возникающих во время компоновки и отсортированные
                по алфавиту публичные символы.
  3 - Detailed  Компоновщик генерирует map-файл, включающий
   (детальный)  список сегментов, стартовый адрес программы,
                любые предупреждения или сообщения об ошибках,
                возникающих во время компоновки, отсортированные
                по алфавиту публичные символы и дополнительную
                карту сегмента.
                Детальная карта сегмента включает в себя адрес,
                длину в байтах, имя сегмента, группу и
                информацию о модуле.
LinkBuffer=0|1
Определяет месторасположения буфера соединений. Значение 1 указывает Delphi на необходимость использования доступного места на локальном диске; 0 указывает на необходимость использования памяти. Значение по умолчанию 0. Данная переменная изменяется посредством группы радиокнопок 'Link Buffer'.

DebugInfo=0|1
Определяет режим, при котором файл библиотеки компонентов компилируется и компонуется с отладочной информацией. Флаг 1 указывает на наличие отладочной информации. Значение по умолчанию 0. Данная переменная может быть изменена с помощью CheckBox 'Compile with debug info' (компиляция с отладочной информацией).

Секция: [Gallery] - Секция "Gallery" отвечает за использование и месторасположение галереи форм и проектов. Отражает настройки галареи: группа радиокнопок на странице Preferences диалога Environment Options.

BaseDir=
Каталог, где Delphi пытается найти файлы галереи. Для того, чтобы галерея была доступна другим пользователям, укажите в значении данной переменной сетевой диск общего доступа. Переменная должна содержать полностью корректный путь, включая букву диска. Данная переменная может быть изменена только с помощью редактирования файла DELPHI.INI. Пример:

    BaseDir=D:\DELPHI\GALLERY
GalleryProjects=0|1
Указывает как Delphi должна отображать диалог Browse Gallery при выборе пункта меню File|New Project. Значение 1 принуждает Delphi показать диалоговое окно Browse Gallery. Значение по умолчанию 0. Даннае переменная может быть изменена с помощью CheckBox 'Use on New Project' (использовать в новом проекте).

GalleryForms=0|1
Указывает Delphi на необходимость показа диалога Browse Gallery при выборе пункта меню File|New Form. Значение 0 указывает на то, что диалог Browse Gallery при этих условиях отображаться не будет. Значение по умолчанию 1. Даннае переменная может быть изменена с помощью CheckBox 'Use on New Form' (использовать в новой форме).

Секция: [Experts] - Секция "Experts" отвечает за эксперты, которые Delphi пытается загрузить и инициализировать при своем запуске. В левой части равенства допускается любая величина, интерпретируемая как имя элемента списка и не используемая непосредственно в работе. Borland в данном случае рекомендует комбинировать имя компании-разработчика и название продукта. Например:

  [Experts]
  ComponentWare.CommExpert=c:\delphi\cware\commexpt.dll
  CodeFast.TheExpert=c:\delphi\codefast\codefast.dll
Секция: [ReportSmith] - Секция "ReportSmith" содержит единственную переменную, определяющую каталог установки ReportSmith.

ExePath=
ExePath указывает на месторасположение RPTSMITH.EXE. Данная переменная размещается в DELPHI.INI во время установки Delphi и может быть изменена только при редактировании DELPHI.INI. Пример:

    ExePath=D:\RPTSMITH
Секция: [Session] - Секция "Session" содержит единственный параметр, указывающий на активный проект при последнем закрытии Delphi.

Project=
Содержит сведения об активном проекте в момент последнего закрытия Delphi. Имеет смысл только в случае, если опция DesktopFile в секции AutoSave имеет значение 1. Значение данной переменно также необходимо для идентификации файла рабочей области проекта (использует расширение .DSK). Значение данной переменной автоматически изменяется при завершении работы Delphi. Пример:

    Project=D:\DELPHI\WORK\MAILAPP.DPR
Секция: [MainWindow] - Секция "MainWindow" определяет основные характеристики главного окна Delphi в части кнопок и палитры компонентов. Секция "SpeedBar Layout" детально описывает содержимое панели кнопок. Точно также, секция <libraryname>.Palette детально описывает содержимое палитры компонентов.

Split=[-1..400]
Указывает горизонтальную координату вертикального разделителя между кнопками и палитрой компонентов. Значение по умолчанию 183. Значение данной переменной изменяется перемещением мышью описанного разделителя.

SpeedHints=0|1
Указывает на возможность показа всплывающих подсказок при попадании курсора мыши в область кнопки на панели инструментов. Значение 0 запрещает вывод подсказок. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью пункта меню Show Hints контекстного меню панели инструментов.

PaletteHints=0|1
Указывает на возможность показа всплывающих подсказок при попадании курсора мыши в область кнопки на палитре компонентов. Значение 0 запрещает вывод подсказок. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью опции меню Show Hints кнопок палитры компонентов.

Speedbar=0|1
Значение 0 запрещает вывод панели инструментов. Значение по умолчанию 1. Значение данной переменной может быть изменено через пункт меню View|Speedbar или пункт Hide контекстного меню панели инструментов.

Palette=0|1
Значение 0 запрещает показ палитры компонентов. Значение по умолчанию 1. Значение данной переменной может быть изменено через пункт меню View|Component Palette или пункт Hide контекстного меню палитры компонентов.

Секция: [Speedbar Layout] - Секция "Speedbar Layout" подробно описывает содержание панели инструментов. Содержание данной секции может быть изменено посредством пункта Configure контекстного меню панели инструментов.

Count=[0..52]
Определяет количество кнопок на панели инструментов. Значение по умолчанию 14.

Button[0..51]=n,x,y
Данная переменная описывает все кнопки панели инструментов. Каждая кнопка имеет уникальный идентификатор, у первой он равен Button0. Число n содержит уникальный "зашитый" id-код. Величина x является числом, определяющим горизонтальную позицию кнопки на панели инструментов. Величина у является числом, определяющим вертикальную позицию кнопки на панели инструментов. Ниже приведен список значений, определяющих описанные характеристики и устанавливаемый по умолчанию, вместе с соответствующими пунктами меню:

    Button0=30001,4,2        ; File|Open Project...
    Button1=30002,27,2       ; File|Save Project
    Button2=30007,4,25       ; File|Open File...
    Button3=30008,27,25      ; File|Save File
    Button4=30009,50,2       ; File|Add File...
    Button5=30010,50,25      ; File|Remove File...
    Button6=30069,79,2       ; View|Units...
    Button7=30070,102,2      ; View|Forms...
    Button8=30068,79,25      ; View|Toggle Form/Unit
    Button9=30004,102,25     ; File|New Form
    Button10=30090,131,2     ;  Run|Run
    Button11=30093,154,2     ;  Run|Program Pause
    Button12=30092,131,25    ;  Run|Trace Into
    Button13=30091,154,25    ;  Run|Step Over
Секция: [Desktop] - Секция "Desktop" содержит единственную переменную, определяющую сохранение настроек рабочей области при завершении работы Delphi. Имеет смысл только в случае, если опция DesktopFile в секции AutoSave имеет значение 1.

SaveSymbols=0|1
Определяет необходимость сохранения информации навигатора символов (browser simbols) вместе с информацией о рабочей области при завершении работы Delphi. Значение данной переменной может быть изменено с помощью группы радиокнопок 'Desktop contents:' (содержание рабочей области). Значение по умолчанию 1.

  Флаг                     Эффект
  ----                     ------
  0 - Только рабочая       Сохранение информации о каталоге, открытых
      область              в редакторе файлах и открытых окон.
  1 - Рабочая область и    Сохранение информации о рабочей области и
      символы              информации навигатора символов, полученной
                           во время последней успешной компиляции.
Секция: [AutoSave] - Секция "Autosave" указывает на файлы и настройки, которые необходимо автоматически сохранять при запуске текущего проекта или завершении работы Delphi. Данная секция соответствует группе настроек 'Autosave options:' (настройки автосохранения) страницы Preferences (настройки) диалога Environment Options (настройки среды).

EditorFiles=0|1
Значение, равное 1, предписывает Delphi сохранять все измененные в Редакторе Кода файлы при вызове пунктов меню Run|Run, Run|Trace Into, Run|Step Over, Run|Run To Cursor или при завершении работы Delphi. Значение по умолчанию 0. Значение данной переменной может быть изменено посредством CheckBox 'Editor files' на странице Preferences диалога Environment Options.

DesktopFile=0|1
Значение, равное 0, запрещает Delphi сохранять расположение окон и настройки рабочей области проекта при его закрытии или завершении работы Delphi. Значение по умолчанию 1. Значение данной переменной может быть изменено посредством CheckBox 'Desktop' на странице Preferences диалога Environment Options.
Примечание: Дальнейшая дискуссия относительно файлов рабочей области расположена ниже в области дискуссий относительно файлов Desktop (.DSK).

Секция: [FormDesign] - Секция "FormDesgin" отвечает за настройки, управляющие внешним видом и поведением сетки форм в режиме разработки. Данная секция соответствует группе настроек 'Form designer:' страницы Preferences диалога Environment Options.

DisplayGrid=0|1
Во время разработки приложения определяет видимость точек сетки формы. Значение, равное 0, не разрешает показ сетки. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью CheckBox 'Display grid' (показывать сетку).

SnapToGrid=0|1
Указывает на необходимость автоматического выравнивания компонентов по сетке при их перемещении посредством мыши. Значение 0 предотвращает автоматическое выравнивание компонентов по сетке. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью CheckBox 'Snap to grid' (выравнивать по сетке).

GridSizeX=[2..128]
Задает горизонтальный шаг сетки. Значение по умолчанию 8. Значение данной переменной может быть изменено с помощью поля редактирования 'Grid Size X'.

GridSizeY=[2..128]
Задает вертикальный шаг сетки. Значение по умолчанию 8. Значение данной переменной может быть изменено с помощью поля редактирования 'Grid Size Y'.

DefaultFont=
Данная переменная отвечает за шрифт по умолчанию для новых форм. Имя шрифта, его размер и, дополнительно, стиль могут быть указаны через разделительные запятые. (Поддерживаемые стили шрифтов - "bold" (жирный) и "italic" (наклонный)). Значение данной переменной может быть изменено только с помощью редактирования DELPHI.INI. Пример:

    DefaultFont=MS Sans Serif, 8, bold, italic
Секция: [Debugging] - Секция "Debugging" содержит настройки, отвечающие за работу интегрированного отладчика и поведения Delphi при выполнении проекта. Данная секция соответствует группе группе настроек 'Debugging:' страницы Preferences диалога Environment Options.

IntegratedDebugging=0|1
Разрешает или запрещает использование интегрированного отладчика Delphi. Значение 0 отключает работу отладчика. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью CheckBox 'Integrated Debugging' (интегрированная отладка).

DebugMainBlock=0|1
При значении, равном 1, отладчик останавливает свою работу при инициализации первого модуля, содержащего отладочную информацию. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Step program block'.

BreakOnExceptions=0|1
При значении, равном 1, приложение, вызвавшее исключительную ситуацию, останавливается, и выводятся класс, сообщение и месторасположение исключения. При значении, равном 0, исключения не прерывают работы приложения. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью CheckBox 'Break on exception' (прерывать при исключениях).

MinimizeOnRun=0|1
При значении, равном 1, Delphi будет сворачивается при запуске текущего проекта. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Minimize on run'.

HideDesigners=0|1
При значении, равном 1, Delphi при запуске проекта будет прятать окна разработки, такие как, например, Инспектор Объектов или окно разработки форм. Значение данной переменной может быть изменено с помощью CheckBox 'Hide designers on run'.

NoResetWarning=0|1
При значении, равном 1, Delphi не выводит предупредительное сообщение при выборе пункта Program Reset (сброс программы). Значение по умолчанию 0. Значение данной переменной может быть изменено только с помощью редактирования DELPHI.INI.

Секция: [Compiling] - Секция "Сompiling" содержит единственную переменную, отвечающую за вывод диалога процесса компиляции приложения. Данная секция соответствует группе настроек 'Compiling:' страницы Preferences диалога Environment Options.

ShowCompilerProgress=0|1
Указывает на необходимость показа диалога процесса компиляции приложения. При значении, равном 1, Delphi производит вывод диалога прогресса в процессе компиляции. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Show compiler progress' (показывать диалог процесса компиляции).

Секция: [Browser] - Секция "Browser" содержит установки, соответствующие странице Browser диалога Environment Options. Данные установки определяют работу функций ObjectBrowser (навигатор объектов) и отображение информации о символах.

Filters=
Значение данной переменной определяет активные фильтры Навигатора Объектов (Object Browser). Значение является суммой величин каждого активного фильтра, указанного в списке ниже.

    Значение   Фильтр
    --------   ------
           2   Constants (константы)
           4   Types (типы)
           8   Variables (переменные)
          16   Functions and Procedures (функции и процедуры)
          32   Properties (свойства)
         128   Inherited (наследуемые)
         256   Virtuals only (только виртуальные)
        1024   Private (частные)
        2048   Protected (защищенные)
        4096   Public (публичные)
        8192   Published (опубликованные)
Значение по умолчанию 15806, означающее активизацию всех фильтров. Каждому фильтру соответствует свой CheckBox в группе 'Symbol filters:'. Для примера, следующее значение переменной активизирует фильтры Properties, Public и Published:
    Filters=12320  ; 8192 + 4096 + 32 = 12320
InitialView=1|2|3
Переменная InitialView определяет тип информации, показываемой навигатором при первом открытии. Значение по умолчанию 2. Значение данной переменной может быть изменено с помощью группы радиокнопок 'Initial view:'
    Значение  Показ
    --------  -----
           1  Units (модули)
           2  Objects (объекты)
           3  Globals (глобальные)
Sort=0|1
При значении, равном 1, Delphi отображает символы в алфавитном порядке, производя сортировку по имени символа. При значении, равном 0, символы отображаются в порядке их объявления. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Sort always'.

QualifiedSymbols=0|1
При значении, равном 1, Delphi отображает верный идентификатор символа. При значении, равном 0, отображается только имя символа. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Qualified symbols'.

CollapsedNodes=
Указывает на объекты древовидной иерархии, которые должны быть свернуты при запуске Навигатора Объектов (ObjectBrowser). Значение данной переменной представляет собой список имен классов, разделенных точкой с запятой. Значение данной переменной может быть изменено с помощью выпадающего списка 'Collapse Nodes:'. Пример:

    CollapsedNodes=Exception;TComponent
ShowHints=0|1
Указывает на возможность показа всплывающих подсказок при попадании курсора мыши в область кнопки фильтра. Значение 0 запрещает вывод подсказок фильтра. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью пункта меню Show Hints контекстного меню Навигатора Объектов (ObjectBrowser).

Секция: [Custom Colors] - Секция "Custom colors" содержит список пользовательских цветов и ограничена шестнадцатью элементами. Каждый цвет определен в виде шестизначного шестнадцатиричного RGB значения. Неиспользуемый элемент цвета обозначен шестнадцатиричной величиной FFFFFFFF. Значения данной секции могут быть созданы и обновлены через диалог выбора цвета свойства любого компонента Color (доступный через двойной щелчок в области свойства Color).

Color[A..P]=
Содержит цвет (RGB) отдельного элемента, определенного пользователем.

Секция: [Print Selection] - Секция "Print Selection" содержит настройки диалога, появляющегося при выборе пункта меню File|Print. Данная секция соответствует группе настроек 'Options:' диалога печати.

HeaderPage=0|1
При значении, равном 1, Delphi в начале каждой страницы помещает информацию, включающую в себя имя файла, текущую дату и порядковый номер страницы. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Header/page number' (заголовок/номер страницы).

LineNumbers=0|1
При значении, равном 1, Delphi размещает в левом поле страницы номера печатаемых строк. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Line numbers'.

SyntaxPrinting=0|1
При значении, равном 1, Delphi для подсветки элементов (ключевых слов) использует жирный, наклонный и подчеркнутый стиль шрифта. При значении, равном 0, Delphi специального форматирования при печати не использует. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью CheckBox 'Syntax print'.

UseColor=0|1
При значении, равном 1, Delphi применяет цветную печать, цвета которой соответствуют цветам редактора. Использование данной переменной подразумевает, что текущий принтер поддерживает печать в цвете. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'Use Color' (использовать цвет).

WrapLines=0|1
При значении, равном 1, для печати символов, выходящих за границу области печати, Delphi использует нужное число строк. При значении, равном 0, строки обрезаются и символы, выходящие за пределы страницы, не печатаются. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью CheckBox 'wrap lines' (переносить строки).

LeftMargin=[0..79]
Содержит число пробелов, используемых в качестве поля между левым краем страницы и началом каждой строки. Значение по умолчанию 0. Значение данной переменной может быть изменено с помощью поля редактирования 'Left margin'.

Секция: [Highlight] - Секция "Highlight" содержит настройки, определяющие цвета синтаксиса и содержимого редактора кода. Значения данной секции могут быть изменены на странице Editor Colors (цвета редактора) диалога Environment Options (настройки среды).

ColorSpeedSetting=0|1|2|3
Указывает на последнюю выбранную цветовую схему. Изменение значения данной переменной не влияет на на фактически используемые цвета индивидуальных элементов. Выпадающий список "Color SpeedSetting" не сохраняет схему цветов; он служит только в качестве средства для быстрой установки цветов сразу всех элементов. Значение по умолчанию 0. Следующая таблица показывает значения, соответствующие каждой цветовой схеме:

  Значение  Цветовая схема
  --------  --------------
         0  Defaults (по умолчанию)
         1  Classic (классика)
         2  Twilight (сумерки)
         3  Ocean (океан)
<Element color>=
Все цветовые величины соответствуют отдельному цветовому элементу. Каждый цветовой элемент использует следующий формат:
    <Element name>=fRGB,bRGB,attr,deffore,defback,fcell,bcell
    Код значения  Значение
    ------------  -------
    fRGB          RGB значение переднего плана
    bRGB          RGB значение фона
    attr          Атрибуты текста; ноль или B, I и U
    deffore       Использовать цвет переднего плана по умолчанию (1=да, 0=нет)
    defback       Использовать цвет фона по умолчанию (1=да, 0=нет)
    fcell         Номер ячейки сетки с цветом переднего плана
    bcell         Номер ячейки сетки с цветом фона
(продолжение в следующем совете) [000896]


Delphi 1

Детальное описание DELPHI.INI (2 из 2)

(продолжение предыдущего совета)

Секция: [Editor] - Данная секция описывает представление и поведение Редактора Кода Delphi (Code Editor). Здесь полностью отражаются настройки страниц Editor options и Editor display.

DefaultWidth=
DefaultHeight=
Данные две переменные, если присутствуют, указывают начальную ширину и высоту окна редактора кода Delphi. Delphi не обновляет значения этих переменных, но они считываются при каждом создании редактора кода. Ширина по умолчанию 406; высота по умолчанию 234. Значение данных переменных могут быть изменены только с помощью редактирования DELPHI.INI.

FontName=
FontSize=
Данные переменные определяют соответственно имя и размер шрифта, используемого редактором кода для вывода текста. Шрифт по умолчанию Courier New, размер по умолчанию 10. Значения данных переменных могут быть изменены с помощью выпадающих списков 'Editor font:' и 'Size:' на странице Editor display.

BlockIndent=[1..16]
Определяет количество пробелов для отступа выделенного блока. Значение по умолчанию 1. Значение данной переменной может быть изменено с помощью выпадающего списка 'Block indent' на странице Editor display.

UndoLimit=[0..]
Определяет количество нажатых комбинаций клавиш, действие которых может быть отменено и которое ограничено доступной памятью. Значение по умолчанию 32,767. Значение данной переменной может быть изменено с помощью выпадающего списка 'Undo limit:' на странице Editor Options.

TabRack=
Данная переменная определяет колонки, в которые должен перемещаться курсор при нажатии клавиши Tab. Каждая "остановка" табулятора должна разделяться от соседней пробелом и быть ее больше. В случае, если задано одно число, табуляторы располагаются равномерно, с использованием указанного числа. Если определены два числа, табуляторы располагаются в заданных позициях и позициях, которые образуются путем вычитания одного значения из другого. Значения табуляторов по умолчанию 9 и 17. Значения данной переменной могут быть изменены с помощью выпадающего списка 'Tab stops:' на странице Editor Options. Примечание: данная переменная имеет эффект только в случае, если включена поддержка табуляторов.

RightMargin=[0..1024]
Определяет границу правого ограничителя редактора кода. Значение по умолчанию 80. Допустимый диапазон находится между 0 и 1024. Значение данной переменной может быть изменено с помощью выпадающего списка 'Right margin:' на странице Editor display.

Extensions=
Combo Box
Определяет маски тех файлов, которые применяют подсветку синтаксиса. В общем случае сюда включаются типичные расширения. Расширения по умолчанию '*.PAS;*.DPR;*.DFM;*.INC;*.INT'. Значение данной переменной может быть изменено с помощью выпадающего списка 'Syntax extensions:' на странице Editor Options. Пример:

    Extensions=*.PAS;*.DPR;*.SRC
FindTextAtCursor=0|1
При значении, равном 1, Delphi помещает текст, на котором расположен курсор, в выпадающий список 'Text To Find' в диалоговом окне Find Text, возникающем при выборе пункта меню Search|Find. При значении по умолчанию, равном 0, текст поиска должен быть введен вручную. Значение данной переменной можно изменить с помощью CheckBox 'Find text at cursor' на странице Editor Options.

BRIEFRegularExpressions=0|1
При значении, равном 1, при поиске текста разрешено пользоваться регулярными выражениями. Значение по умолчанию 0. Значение данной переменной можно изменить с помощью CheckBox 'BRIEF regular expressions' на странице Editor Options.

PreserveLineEnds=0|1
Определяет необходимость сохранения или преобразования символа конца строки в символ перевода каретки (carriage return/line feed). При значении, равном 0, Delphi преобразует символы конца строки в символы перевода каретки. Значение по умолчанию 1. Значение данной переменной можно изменить с помощью CheckBox 'Preserve Line Ends' на странице Editor display.

FullZoom=0|1
Определяет, заполняет ли редактор кода экран целиком при его максимизации. При значении, равном 0 (значение по умолчанию), редактор кода не закрывает при максимизации главное окно Delphi. Значение, равное 1, позволяет при максимизации редактору кода занимать весь экран целиком. Значение по умолчанию 1. Значение данной переменной можно изменить с помощью CheckBox 'Zoom to full screen' на странице Editor Display.

DoubleClickLine=0|1
При значении, равном 1, Delphi полностью выделяет строку при двойном щелчке мышью на любом ее символе. При значении, равном 0 (значение по умолчанию), выделяется только выбранное слово. Значение данной переменной можно изменить с помощью CheckBox 'Double click line' на странице Editor Options.

BRIEFCursors=0|1
Указывает Delphi на необходимость использования в редакторе коде курсора BRIEF-стриля. При значении, равном 1, Delphi использует курсор Brief-стиля. Значение по умолчанию 0. Значение данной переменной можно изменить с помощью CheckBox 'BRIEF cursor shapes' на странице Editor Display.

ForceCutCopyEnabled=0|1
При значении, равном 1, опции меню Edit|Cut и Edit|Copy будут доступны даже тогда, когда никакой текст не выбран. Значение по умолчанию 0. Значение данной переменной можно изменить с помощью CheckBox 'Force cut and copy enabled' на странице Editor Options.

KeyBindingSet=0|1|2|3
Указывает на текущую "встроенную" функциональную раскладку клавиатуры Delphi (Key Mapping). Значение по умолчанию 0. Значение данной переменной можно изменить с помощью списка 'Keystroke mapping:' на странице Editor Display. Следующая таблица показывает соответствие значений данной переменной функциональной раскладке клавиатуры:

    Значение  Раскладка
    --------  ---------
           0  Default (по умолчанию)
           1  Classic (классика)
           2  Brief (резюме)
           3  Epsilon (эпсилон)
Mode=
Данная переменная содержит состояние шестнадцати флагов, доступных на странице Editor Options и двух на странице Editor Display. Значение переменной представляет собой сумму значений величин, соответствующих каждому отмеченному CheckBox. Все приведенные ниже величины соответствуют тем CheckBox'ам на странице Editor Options, чьи имена приведены в начале их описываемых функций.
      1  Insert mode (режим вставки) - Вставляет текст в позицию
         курсора, не замещая текущего.
      2  Auto indent mode (режим автопозиционирования) - Позиционирует
         курсор на место первого непустого символа предыдущей непустой
         строки при нажатии клавиши Enter.
      4  Use tab character (использовать символ табулятора) -
         Вставляет символ табулятора. Если флаг выключен,
         вставляется символ пробела. Данный флаг и флаг
         Smart Tabs взаимоисключаемые. Если последний выставлен,
         данный флаг выключен.
     16  Backspace un-indents - Возвращает точку ввода на
         предшествующий уровень при нажатии клавиши Backspace, если
         курсор находится в первом непустом символе строки.
     32  Keep trailing blanks (сохранение конечных пробелов) -
         сохраняет конечные пробелы и табуляторы в случае их наличия в
         конце строки.
     64  Optimal fill (оптимальное заполнение) - Начинает каждую новую
         строку с минимально возможным количеством символов, используя
         при необходимости табуляторы и пробелы.
    128  Cursor through tabs (курсор через табулятор) - позволяет
         с помощью курсорных клавиш перемещать курсор к началу каждого
         табулятора.
    256  Group undo (групповая отмена) - Отменяет последнюю команду
         редактирования, а также последующую команду редактирования
         того же типа при нажатии Alt+Backspace, Ctrl+Z или выборе
         пункта меню Edit|Undo.
    512  Persistent blocks (устойчивые блоки) - Сохраняет выделенными
         блоки при перемещении курсора до тех пор, пока не будет
         выделен новый блок.
   1024  Overwrite blocks (перезапись блоков) - Заменяет выделенный
         блок текста вновь набранным текстом. Если также выставлен
         флаг "Persistent Blocks" (устойчивые блоки), вводимый текст
         добавляется к выделенному блоку.
   4096  Create backup file (создавать резервный файл) - Создает
         резервный файл при сохранении исходных файлов. Данный флаг
         выставляется с помощью CheckBox 'Create backup file' на
         странице Editor Display.
   8192  Use Syntax highlight (использовать подсветку синтаксиса) -
         Включает подсветку синтаксиса.
  16384  Visible right margin (показывать ограничительную линию) -
         Делает видимой правую ограничительную линию в редакторе кода.
         Данный флаг выставляется с помощью CheckBox 'Visible right
         margin' на странице Editor Display.
  32768  Smart tabs (умные табуляторы) - Устанавливает табуляторы на
         первом символе, не являющимся белым пробелом, предыдущей
         строки. Данный флаг и флаг Use tab character
         взаимоисключаемые.
 131072  Cursor beyond EOF (курсор за EOF - End Of File, конец файла) -
         допускает расположение курсора за символом EOF (end-of-file).
 262144  Undo after save (отмена после сохранения) - Допускает поиск
         изменений после сохранения.
EditorSpeedSetting=0|1|2|3
Указывает на последнюю выбранную схему эмуляции. Изменение значения этой переменной не влияет непосредственно на функциональную раскладку клавиатуры или использование настроек редактора. Выпадающий список Editor SpeedSetting не сохраняет схему эмуляции; он служит только в качестве средства для быстрой установки одновременно сразу нескольких настроек редактора. Значение по умолчанию 0. Следующая таблица показывает соответствие значений данной переменной набору изменяемых значений:
    Значение  Быстрая настройка
    --------  -----------------
           0  Default keymapping (раскладка по умолчанию)
           1  IDE classic (классический IDE)
           2  Brief emulation (резюме-эмуляция)
           3  Epsilon emulation (эпсилон-эмуляция)
Секция: [.Palette] - Данная секция описывает содержимое палитры компонентов. Имя каждого элемента данной секции соответствует определенному имени страницы в палитре компонентов. Значение каждого элемента представляет собой список имен типов компонентов данной страницы, разделенные между собой точкой с запятой. Данная секция создается после конфигурирования каждой библиотеки компонентов на странице Palette диалога Environment Options.

Секция: [Transfer] - Секция "Transfer" описывает пункты меню Tools. Значение данной секции определяется с помощью диалога Tool Properties. Вызвать диалог Tool Properties можно с помощью пункта меню Options|Tools.

Count=
Определяет количество пунктов меню Tools. Данная переменная изменяется путем добавления или удаления программ из списка диалога Tools Options.

Title#=
Path#=
WorkingDir#=
Params#=
Данные элементы описывают каждый элемент, представляющий собой пункт меню Tools. Каждый элемент списка имеет число-идентификатор, указывающий на позицию элемента в списке меню, первый элемент имеет идентификатор, равный нулю.

    Title#       Определяет текст данного пункта меню Tools.
    Path#=       Определяет полный путь к выполняемой пунктом меню программе.
    WorkingDir#  Определяет текущий каталог запуска программы.
    Params#      Определяет параметры, передаваемые программе при запуске.
Секция: [Closed Files] - Секция "Closed Files" содержит полное имя пути последних трех закрытых файлов проекта. Файлы располагаются в порядке времени их последнего использования, т.е. последний использованный файл будет расположен первым. Каждая запись имеет вид File_#=.DPR,col1,row1,col2,row2 где # - 0, 1 или 2. Col1 идентифицирует первую видимую колонку в редакторе кода, row1 - первую видимую строку. Col2 - колонка курсора, row2 - строка курсора.

Секция: [VBX] - Секция VBX содержит установки, доступные при установке VBX в палитру компонентов Delphi.

VBXDir=
Содержит каталог, из которого был в последний раз установлен VBX. Значение данной переменной сохраняется Delphi автоматически при установке VBX.

UnitDir=
Содержит каталог, в котором располагается исходный код, используемый последним VBX, установленным Delphi. Значение данной переменной сохраняется Delphi автоматически при установке VBX.

PalettePage=BVSP
Содержит имя страницы палитры компонентов, в которую был включен последний VBX, установленный Delphi. Значение данной переменной сохраняется Delphi автоматически при установке VBX.

Секция: [Version Control] (контроль версии)

VCSManager=
Данная переменная определяет верный путь к DLL менеджера управления версиией (Version Control manager). Delphi Client/Server, включаюет в себя поддержку групповой разработки, где менеджер управления версией имеет имя STDVCS.DLL и расположен в каталоге \BIN. Пример:

    VCSManager=d:\delphi\bin\stdvcs.dll
Секция: [Resource Expert] - Секция "Resource Expert" присутствует только в случае наличия установленного эксперта ресурсов Delphi (Resource Expert). В данной секции описан только один параметр.

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

    RCIncludePath=D:\DELPHI\WORK;D:\RESOURCE\INCLUDE
Секция: [History_##] - DELPHI.INI содержит несколько "history" секций, каждая из которых имеет свое уникальное число, расположенное после символа подчеркивания. Каждая "history" секция напрямую соответствует определенному выпадающему списку в диалоге Delphi. Каждая секция содержит по крайней мере один элемент с именем Count, указывающий количество "history"-элементов в секции. Каждый реальный history-элемент имеет имя, начинающееся с H и заканчивающееся порядковым номером в history-списке, где первый элемент имеет имя H0. Следующая таблица показывает соответствие выпадающего списка и имени секции, отвечающей за элементы данного списка. Указаны только сохраняемые "истории" Delphi.

  Секция        Месторасположение выпадающего списка
  -----------   -------------------------------------------------
  [History_0]   'Text to find' (Текст для поиска), диалог Find
                Text или Replace Text
  [History_1]   'Replace with' (заменить), диалог Replace Text
  [History_2]   'Output directory' (каталог выхода), страница
                Directory/conditionals диалога Project Options
  [History_3]   'Search path' (путь поиска), страница Directory/
                conditionals диалога Project Options
  [History_7]   'Conditionals' (условия), страница Directory/
                conditionals диалога Project Options
  [History_8]   'Undo Limit' (предел отмены), страница Editor
                options диалога Environment Options
  [History_9]   'Right margin' (правое поле), страница Editor
                display диалога Environment Options
  [History_10]  'Tab stops' (табуляторы), страница Editor options
                диалога Environment Options
  [History_11]  'Syntax extensions' (синтаксические расширения),
                страница Editor options диалога Environment
                Options
  [History_12]  'Enter new line number' (ввод номера новой
                строки), диалог Go to Line Number
  [History_18]  'Block indent' (отступ блока), страница Editor
                options диалога Environment Options
  [History_20]  'File name' (имя файла), диалог Open Project
  [History_23]  'File name' (имя файла), диалог Install VBX file
  [History_25]  'File name' (имя файла), диалог Unit file name
                (при установке VBX)
  [History_33]  'Collapse nodes' (скрытые узлы), страница Browser
                диалога Environment Options
  [History_34]  'Library path' (путь к библиотекам), страница
                Library диалога Environment Options
  [History_35]  'File name' (имя файла), диалог Open Library
  [History_36]  'File name' (имя файла), диалог Save Project1 As
[000898]


Delphi 1

Установка Delphi в сети

Установка Delphi на сетевой диск

Примечание:

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

Данный документ подразумевает в основном работу с платформами Windows версии 3.1 или 3.11. При использовании другой операционной системы должны быть, естественно, применены другие установки.

*****************************************************************

  1. Установите Delphi в сети, используя любую рабочую станцию, но не забудьте проверить опцию "Windows Lan", если Windows установлен на сервере в каталоге только для чтения.
  2. Измените файл DELPHI.INI, расположенный в каталоге windows.
            -измените:
               [Globals]
               PrivateDir = ваш локальный каталог
        -добавьте:
               [Library]
               SearchPath = Сетевой диск:\DELPHI\LIB
               ComponentLibrary= ваш локальный каталог\COMPLIB.DCL
    Это позволит каждому пользователю иметь собственные персональные настройки, персональный DFM файл, а также персональную библиотеку компонентов. Если желательно наличие общей библиотеки компонентов, строку ComponentLibray необходимо пропустить.
  3. Скопирйте COMPLIB.DCL и DELPHI.DMT из каталога DELPHI\BIN в локальный персональный каталог.
  4. Скопируйте DELPHI.INI на все машины, на которых предполагается запуск Delphi.

    Если Windows установлен в сети, INI-файл все равно должен быть установлен в локальных каталогах, поскольку он необходим для успешной работы.

  5. Если во время установки был выбран пункт WINSYS, то будет создан каталог DELPHI\WINSYS. В движке установки имеется ошибка, т.к. не все необходимые файлы включены в список устанавливаемых файлов. Скопируйте файлы из каталогов CDROM:\RUNIMAGE\WINDOWS и CDROM:\RUNIMAGE\WINDOWS\SYSTEM в каталог WINSYS. Затем данный каталог должен быть включен в переменную Path (путь). Если вы хотите скопировать эти файлы в каталог WINDOWS\SYSTEM, не забудьте их предварительно сохранить, что может пригодится в случае файловых коллизий. Вы должны взять на себя заботу о сохранении файлов более новых версий. В этом вам может помочь DOS-программа REPLACE.EXE.
  6. Если каталог WINSYS создан не был (Шаг 5), скопируйте содержимое каталогов CD:\RUNIMAGE\WINDOWS и CD:\RUNIMAGE\WINODWS\SYSTEM на все рабочие станции. Поместите эти файлы в отдельный каталог и включите в путь. (Это сделает удаление Delphi намного проще.)
  7. Для использования Delphi скопируйте файл группы, созданный в каталоге Windows, на другие необходимые рабочие станции.
  8. C помощью Program Manager создайте на этих машинах группы.
  9. Модифицируйте переменную PATH (путь) на всех рабочих станциях, на которых должна работать Delphi, следующим образом:

   PATH=C:\IBLOCAL\BIN;C:\DELPHI\BIN
    Все пользователи перед использованием Delphi должны загрузить DOS-утилиту SHARE (в предположении, что используется Windows 3.1).
  10. Следующая строчка должна быть добавлена в AUTOEXEC.BAT каждому пользователю Delphi:
        SHARE /F:4096 /L:40
  11. Модифицируйте WIN.INI на всех машинах (в предположении, что Windows установлена на локальном диске), добавляя следующее:
        [IDAPI]
    DLLPATH=X:\IDAPI;C:\IDAPI
    CONFIGFILE01=X:\IDAPI\IDAPI.CFG

    [Borland Language Drivers]
    LDPath=X\IDAPI\LANGDRV

    [BWCC]
    BitmapLibrary=BWCC.DLL

    [Interbase]
    RootDirectory=X:\IBLOCAL

    [Paradox Engine]
    UserName=PxEngine
    NetNamePath=X:\
    MaxTables=64
    RecBufs=64
    MaxLocks=64
    MaxFiles=64
    SwapSize=64
    NetNameFDSM=

    [DDE Servers]
    DBD=X:\DBD\DBD

    [DBD]
    WORKDIR=X:\DBD
    PRIVDIR=C:\DBD\DBDPRIV
    Где X - сетевой диск и путь, куда устанавливается программа. Имейте в виду, что PRIVDIR установлен локально.
Примечание: Delphi записывает многочисленные INI-файлы в каталог Windows. Эти файлы могут копироваться на другие рабочие станции только в случае их отсутствия там. Если они являются причиной неработоспособности Delphi, вы должны вручную добавить содержимое новых файлов к содержимому уже существующих.

INI-файлы, устанавливаемые Delphi:

RS_SQLIF INI
WINHELP  INI
MULTIHLP INI
DELPHI   INI
ODBCINST INI
ODBC     INI
RPTSMITH INI
RS_RUN   INI
ODBCISAM INI
Конфигурация, описанная выше, должна учитывать установку флага "только для чтения" после окончательной установки Delphi, но, к сожалению, это было протестировано только в случае локальной установки Windows. [000934]


Delphi 1

Сущность ООП

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

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

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

interface
PPersonRecord = ^TPersonRecord;
TPersonRecord = record
FirstName: String;
LastName: String;
Age: Byte;
Active: Boolean;
end;

TPersonFile = class(TObject)
private
FFileName: TFileName;
FFile: File of TPersonRec;
public
constructor Create(AFileName: TFileName);
destructor Destroy; override;
procedure LoadRecord(Index: Integer);
procedure SaveRecord(Index: Integer);
procedure Add(NewPersonRecord: TPersonRecord);
procedure Change(ChangedPersonRecord: TPersonRecord; Index: Integer);
procedure Delete(Index: Integer);
procedure List(AStringList: TStringList);
property Person[Index: Integer]: TPersonRecord read LoadRecord write SaveRecord;
end;

implementation

constructor TPersonFile.Create(AFileName: TFileName);
begin
inherited.Create;
AssignFile(FFile,AFileName) ;
Reset(FFile,SizeOf(TPersonRec));
New(FPersonRecord);
end;

destructor TPersonFile.Destroy;
begin
CloseFile(FFile);
Dispose(FPersonRecord);
inherited Destroy;
end;

function TPersonFile.LoadRecord(Index: Integer): PPersonRec;
begin
{ позиция файла в точке коррекции для чтения записи }
{ ... }
end;

procedure TPersonFile.SaveRecord(Index: Integer);
begin
{ позиция файла в точке коррекции для записи записи }
{ ... }
 end;

procedure TPersonFile.Add(NewPersonRecord: TPersonRecord);
begin
{ файл позиционируется в конец для записи записи }
{ ... }
end;

procedure TPersonFile.Change(ChangedPersonRecord: TPersonRecord; Index: Integer);
begin
{ именение TStatus ??? }
{ позиция файла в точке коррекции для записи записи }
{ ... }
end;

procedure TPersonFile.Delete(Index: Integer);
begin
{ изменение TStatus ??? }
{ позиция файла в точке коррекции для записи записи }
{ ... }
end;

procedure TPersonFile.List(AStringList: TStringList);
begin
{ в цикле обходим все записи, пополняя AStringList??? }
end;

OK, я надеюсь вы поняли мою идею. Вышеприведенный код взят мною из головы и, вероятно, несвободен от ошибок, поскольку я не до конца понял как работает тип file (для доступа к бинарному файлу я использую TFileStream), но идея следующая: инкапсуляция ваших функций работы с файлом в невизуальный объект как показано выше.

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

MyPersonFile := TPersonFile.Create('c:\person.dat');

Естественно, вам необходим модуль, в котором вы объявляете TPersonFile в секции используемых модулей, а в классе формы необходимо поле с именем MyPersonFile. Вам также необходимо помнить об освобождении MyPersonFile в методе формы onClose. Я думаю вы сообразите как разместить в вашей программе необходимые элементы управления (менюшки, кнопки и прочие причиндалы), хотя бы для того, чтобы с помощью них можно было бы открыть файл.

Теперь вы должны разместить на форме компоненты типа Edit, CheckBox и др., отображающие и позволяющие редактировать поля записи через свойство Record. Убедитесь в том, что вы поддерживаете должный порядок, и освобождаете объект (запись) после его создания и использования. Конечно, эту работу красивой не назовешь, но от нее вас никто еще не освобождал. Вот красота ООП:

*После создания комбинации объект / форма диалога вся работа уже сделана.*

Вот другая хорошая вещь:

*Если вы изменяете ваш пользовательский интерфейс (например, при отказе от кучи диалогов или от использования Delphi (молчу-молчу)), ООП предоставляет вам простой и легкий в использовании способ переноса логики приложения, инкапсулированной в объекте TPersonFile.* [000648]


Delphi 1

Список зависимых файлов

Используйте утилиту tdump, включенную в поставку delphi:

  tdump -eiNAM xyz.exe >tempfile
Эта команда просканирует файл xyz.exe c параметром MODULE NAME TABLE (таблица имен модулей) и запишет результат в Файла tempfile.

Результат представляет собой список всех DLL, загружаемых программой.

Исключение составляет загрузка DLL с помощью функции API LoadLibrary, но это редкий случай. [000660]


Delphi 1

Проблема видеокарточки в Win95

В файле .TXT в каталоге windows об этом говорится:

Карточки S3 конфликтуют с портами COM4 и модемами. Если в этой конфигурации у вас появились проблемы с модемом, назначьте ему другой COM порт. Или откройте свойства Системы в Панели Управления, щелкните на закладке Производительность, перейдите в Графику и передвиньте движок в позицию "Нет".

Я не захотел выбрасывать из конфигурации мой новый видеоадаптер, т.к. "Он стоит хороших денег для хорошей работы", поэтому я "посадил" мышь на COM 2, модем на COM3 (они занимали, соответственно, порты 1 и 4), и все заработало как миленькое.

Tom Ruby [000736]


Delphi 1

Миниатюрное Delphi-приложение

Тема: Маленький EXE
От: Bob Swart 100434,2072
К: James Foxall 74160,3615

... мне нужно отобразить один вшивый MessageBox! Какие идеи по-поводу уменьшения размера монстрового EXE-файла?

Следующая программа генерирует .EXE-файл размером менее чем 2Кб (1176 байт с моей специальной конфигурацией)...

{$A+,B-,D-,F-,G+,I-,K-,L-,N-,P-,Q-,R-,S-,T-,V-,W-,X+,Y-}
{$M 32768,0}
uses WinTypes, WinProcs;
begin
MessageBox(GetActiveWindow, 'Вася, это ты?', 'Dr.Bob',
MB_ICONINFORMATION OR MB_OK)
end.

Успехов,
Dr. Bob (drbob@pi.net) [000745]


Исследование кода, генерируемого Delphi

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

Введение

На этот раз я представляю Вам сугубо теоретическое исследование, и все рассматриваемые программы написал сам. Кроме них нам понадобятся Delphi и исходный код VCL (я использовал Delphi 4.0 Client/Server Edition), а также дизассемблер IDA Pro (я пользуюсь v3.8b). Полагаю Вы понимаете Ассемблер и имеете опыт в написании программ на Delphi с применением VCL.

Delphi генерирует огромное количество мёртвого и практически одинакового кода для любого приложения, использующего VCL. Тем не менее множество приложений относительно успешно создаются на Delphi, как же бедным исследователям отделять зёрна от плевел?

Вопрос этот совершенно не нов, первым (из известных мне) трудом подобного рода был материал LaZaRuS'а "Нахождение стандартных функций в программах на Delphi/C++ Builder" (http://www.phase-one.com.au/fravia/laza_s11.htm) на Fravia летом этого года. Для тех, кто не знаком с английским, краткий конспект шедевра LaZaRuSа: он сделал тоже, что и я (трудно в наше время быть оригинальным...) - написал тестовое приложение (правда, он использовал Borland C++ Builder), а потом дизассемблировав его W32Dasm'ом, попытался выяснить, как выглядят типичные действия по заполнению окна регистрации на Ассемблере.

Получилось у него примерно следующее:

  • функция, закрывающая модальный диалог, должна поместить значение, возвращаемое методов ShowModal, помещает это значение по смещению 0144h. Сами значения можно посмотреть в файле Source/Rtl/Win/windows.pas:
      ID_OK=1
  ID_CANCEL=2
  ID_ABORT=3
  ID_RETRY=4
  ID_IGNORE=5
  ID_YES=6
  ID_NO=7
  ID_CLOSE=8
  ID_HELP=9
  • для разрешения/запрещения кнопок используется смещение 40h в классе TButton;
  • для быстрого поиска функции MessageBox() (скажем, в SoftICE) нужно найти вызов GetActiveWindow(), затем собственно MessageBox() вслед за ним SetActiveWindow() (!);
  • функция, записывающая или считывающая текст из элементов управления TEdit, делает это через указатель по смещению 01CCh.
А теперь плохая новость - для Delphi 4 (я исхожу из предположения, что все новые программы обычно пишутся на самых новых средствах разработки) всё вышеизложенное не соответсвует действительности.

Обнаружение нужных классов

Я набросал в несистематическом порядке несколько элементов управления (TEdit, TButton и TBitBtn - именно они чаще всего применяются в диалогах регистрации), и написал примерно такой непритязательный код:

type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Button1: TButton;
Button2: TButton;
Button3: TButton;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure MyClickHandler(Sender: TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
MessageDlg('BitBtn1Click',mtConfirmation, [mbOk], 0);
ModalResult := mrOk;
end;

procedure TForm1.MyClickHandler(Sender: TObject);
begin
MessageDlg('MyClickHandler',mtConfirmation, [mbOk], 0);
ModalResult := mrCancel;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
MessageDlg('FormShow',mtConfirmation, [mbOk], 0);
BitBtn2.OnClick := MyClickHandler;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
S: String;
begin
S := Trim(Edit1.Text) + Trim(Edit2.Text);
Application.MessageBox(PChar(S),'Button1Click',IDOk);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
MessageDlg('Button2Click',mtConfirmation, [mbOk], 0);
Edit1.Enabled := not Edit1.Enabled;
Button3.Enabled := not Button3.Enabled;
end;

Чтобы мне было легко идентифицировать мой же собственный код, я поместил в каждой функции вызов MessageDlg(). Также здесь не все обработчики назначаются во время проектирования - функция MyClickHandler() назначается обработчиком динамически при показе формы (в методе FormShow()). Компилируем, запускаем - безделица, конечно, но работает... Размер EXE-файла 329728 байт! И это буквально за пять минут! Да я - серьезный программист!

Далее неплохо было бы дизассемблировать полученный файл.

Общее замечание: строки в Delphi в бинарном виде выглядят не как во всех прочих языках - т.е. не оканчиваются нулевым символом, отчего IDA Pro не опознаёт их как строки. Вначале идёт один байт - длина, а далее - сама строка, причём её конец никак более не обозначен. Это верно для так называемых коротких строк, длина которых меньше 256 байт. К несчастью, именно такими строками пользуется механизм поддержки классов.

Надо заметить, что, несмотря на все свои достоинства, IDA Pro не справляется со всеми тонкостями программ, написанных на Delphi - утверждает, что на месте VTBL находится код, не распознаёт строк в стиле Pascal'я и прочие мелочи - так что нас выручит только её интерактивность. И, кстати, не забудьте применить файл сигнатур для VCL 4 - для моего файла IDA Pro опознала аж 2297 библиотечных функций!

Для начала посмотрим, как выглядит стартовая процедура Start() (004444A8h):

 push    ebp
 mov     ebp, esp
 add     esp, 0FFFFFFF4h
 mov     eax, offset dword_0_444398
 call    @@InitExe       ; ::`intcls'::InitExe
 mov     eax, ds:off_0_445CDC
 mov     eax, [eax]
 call    @TApplication@Initialize ; TApplication::Initialize
 mov     ecx, ds:off_0_445DAC
 mov     eax, ds:off_0_445CDC
 mov     eax, [eax]
 mov     edx, ds:off_0_443F30
 call    @TApplication@CreateForm ; TApplication::CreateForm
 mov     eax, ds:off_0_445CDC
 mov     eax, [eax]
 call    @TApplication@Run ; TApplication::Run
 call    @@Halt0         ; ::`intcls'::Halt0
Самым многообещающим здесь выглядит вызов метода TApplication::CreateForm(), аргументом ему передаётся некий указатель - на структуру RTTI (Run-Time Type Information, информация о типе времени исполнения) класса нашей формы TForm1. Исследуем ее.

По смещению DWORD от начала структуры RTTI расположен указатель на VTBL. Далее идут 12 нулей (возможно выравнивание по границе, а возможно эти три DWORDа тоже что-нибудь означают). А по смещению 10h в расположен указатель (DWORD) на некую рекурсивную структуру, которую я назвал список наследственности:

список наследственности
Смещение | Тип | Описание
0 | BYTE | значение не выяснено
1 | BYTE | длина N Pascal-строки
2 | String | имя класса
N+2 | DWORD | ещё один указатель на VTBL
N+6 | DWORD | указатель на указатель (!) предка этого класса; обычно он указывает на 4 байта дальше себя, но я не берусь этого гарантировать
N+10 | WORD | значение не выяснено
N+12 | BYTE | длина Pascal-строки
N+13 | String | имя модуля, где определяется этот класс

Путешествуя по этому списку, можно с лёгкостью выяснить генеалогическое дерево класса TForm1:

  • TForm, файл Forms
  • TCustomForm, файл Forms
  • TScrollingWinControl, файл Forms
  • TWinControl, файл Controls
  • TControl, файл Controls
  • TComponent, файл Classes
  • TPersistent, файл Classes
  • TObject, файл System
У последнего указатель на предка содержит нулевое значение - видимо, означая конец списка.

Вернёмся к структуре RTTI класса TForm1. По смещению 14h находится указатель на компоненты, которыми владеет данный класс. Это все элементы списка Components во время разработки. Эта структура имеет довольно простой вид:

Структура RTTI класса TForm1
Смещение | Тип | Описание
0 | WORD | число CompCount различных классов компонентов
2 | DWORD | указатель на массив указателей на структуры RTTI этих классов. Первым элементом этого массива является WORD - число его элементов, далее расположены указатели на структуры RTTI.

Сразу вслед за ней идут CompCount структур, описывающих эти компоненты:

CompCount структур
Смещение | Тип | Описание
0 | WORD | смещение в классе, по которому находится указатель на компонент
1 | WORD | значение не выяснено
2 | WORD | индекс в массиве структур RTTI - по нему определяется класс компонента
N+2 | WORD | длина Pascal-строки
N+6 | String | имя компонента (например, Edit1)

Самым важным здесь являются смещение на компонент во включающем классе и его тип. Запомним их для компонентов в форме TForm1:

Смещение на компонент во включающем классе и его тип
Имя компонента | Смещение в классе | Тип компонента
Edit1 | 02C4h | 0 - TEdit
Edit2 | 02C8h | 0 - TEdit
Button1 | 02CCh | 1 - TButton
Button2 | 02D0h | 1 - TButton
Button3 | 02D4h | 1 - TButton
BitBtn1 | 02D8h | 2 - TBitBtn
BitBtn2 | 02DCh | 2 - TBitBtn
BitBtn3 | 02E0h | 2 - TBitBtn

Снова вернёмся к структуре RTTI класса TForm1. По смещению 18h находится указатель на одну из самых полезных структур - на массив обработчиков событий (но только тех, которые заданы во время проектирования!). Первым элементом этого массива идёт WORD, определяющий длину этого массива, а его элементы имеют такие поля:

Структура RTTI класса TForm1
Смещение | Тип | Описание
0 | WORD | тип обработчика
2 | DWORD | указатель на функцию-обработчик
6 | BYTE | длина Pascal-строки
7 | String | имя функции-обработчика

Тип определяет количество и размерность аргументов. Для обработчиков OnClick он равен 13h, для OnShow 0Fh.

Не прошло и получаса, а я уже нашёл свой код. Мы рассмотрим его чуть позже (пока Вы можете назвать найденные функции как в оригинале), а сейчас продолжим рассмотрение структуры RTTI класса. По смещению 24h записывается размер класса (DWORD) - для TForm1 он составляет 02E4h байт. Сравните его с таблицей смещений компонентов. По смещению 28h находится указатель на структуру RTTI класса-предка. У объекта TObject он равен нулю. По смещению 20h находится указатель на Pascal-строку - имя класса. Я повторю всю вышеизложенную информацию в следующей таблице:

Структура RTTI класса TForm1
Смещение | Тип | Описание
0 | DWORD | указатель на VTBL
4 | 12 байт | значение не выяснено
10h | DWORD | указатель на список наследований
14h | DWORD | указатель на компоненты, которыми владеет данный класс
18h | DWORD | указатель на массив обработчиков событий
1Ch | DWORD | значение не выяснено
20h | DWORD | указатель на Pascal-строку - имя класса
24h | DWORD | размер класса
28h | DWORD | указатель на структуру RTTI класса-предка данного класса

По смещению 2Ch идёт таблица методов. Порядок следования методов в ней мне не до конца ясен, однако я уверен, что в ней должны содержаться конструктор и деструктор данного класса.

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

BitBtn1Click

BitBtn1Click    proc near
                push    ebx
                mov     ebx, eax
                push    0
loc_0_444149:
                mov     cx, ds:word_0_444168
                mov     dl, 3
                mov     eax, offset aBitbtn1click
                call    @MessageDlg
loc_0_44415C:
                mov     dword ptr [ebx+22Ch], 1
                pop     ebx
                retn
BitBtn1Click    endp
Простой и понятный код. Подспудно выясняется, что закрытие формы осуществляется записью DWORD'а (ModalResult) по смещению 022Ch в экземпляре классе. Обратите внимание на механизм передачи параметров - по умолчанию Delphi использует соглашение вызова register - параметры передаются слева-направо, используя регистры EAX, EDX и ECX, очистку стека производит вызываемая функция. Соответственно, первый (неявный) аргумент для этой функции, представляющий собой указатель на класс, передаётся в регистре EAX.

OnFormShow

OnFormShow      proc near
                push    ebx
                mov     ebx, eax
                push    0
                mov     cx, ds:word_0_4441F4
                mov     dl, 3
                mov     eax, offset aFormshow
                call    @MessageDlg
                mov     eax, [ebx+2DCh]
                mov     [eax+108h], ebx
                mov     dword ptr [eax+104h], offset MyClickHandler
                pop     ebx
                retn
OnFormShow      endp
Здесь тоже можно увидеть кое-что интересное. Во-первых, смещение 02DCh не напоминает Вам о компоненте BitBtn2? Во-вторых, обратите внимание, что здесь присваиваются два указателя. Почему? Потому что мы присваиваем не просто указатель на функцию. Все обработчики являются "of object" - т.е. методами классов. Соответственно, присваивается сначала указатель на экземпляр класса (в данном случае Self) по смещению 0108h, а затем - указатель на нашу функцию MyClickHandler(). Замечу, что больше указатель на эту функцию не встречается. Это сильно затрудняет поиск динамически назначенных обработчиков событий. Нам может помочь только ещё одно обстоятельство - все строковые константы, используемые в функции, Delphi располагает следом за самой функцией.

Button1Click

Button1Click    proc near
var_10          = dword ptr -10h
var_C           = dword ptr -0Ch
var_8           = dword ptr -8
var_4           = dword ptr -4
                push    ebp
                mov     ebp, esp	; фрейм стека для локальных переменных
                xor     ecx, ecx
                push    ecx
                push    ecx
                push    ecx
                push    ecx   ; 4 нуля в стек
                push    ebx
                mov     ebx, eax	; в eax - указатель на экземпляр класса
                xor     eax, eax
                push    ebp
                push    offset loc_0_4442B0
        push 	dword ptr fs:[eax]
                mov     fs:[eax], esp
...
loc_0_4442B0:
        jmp     @@HandleFinally
IDA Pro неправильно опознала аргументы функций - ведь они передаются в регистрах, а не через стек. Кроме того, здесь задействуется механизм обработки исключений. Для передачи управления при исключениях Delphi использует сегментный регистр FS - в FS:[0] помещается текущий указатель стека ESP, предыдущее же значение перед этим помещается в стек. Кроме того, в стек также помещается адрес функции - обработчика блока finally. Также обратите внимание на инициализацию четырёх локальных переменных типа DWORD нулями.
     lea     edx, [ebp+var_C]
     mov     eax, [ebx+2C8h]	; смещение 02C8h не напоминает Вам о Edit2?
     call    @TControl@GetText ; TControl::GetText
     mov     eax, [ebp+var_C]
     lea     edx, [ebp+var_8]
     call    @Trim
     mov     eax, [ebp+var_8]
     push    eax
     lea     edx, [ebp+var_C]
     mov     eax, [ebx+2C4h]	; а 02C4h - о Edit1?
     call    @TControl@GetText ; TControl::GetText
     mov     eax, [ebp+var_C]
     lea     edx, [ebp+var_10]
     call    @Trim
     mov     edx, [ebp+var_10]
     lea     eax, [ebp+var_4]
     pop     ecx
     call    @@LStrCat3      ; ::'intcls'::LStrCat3
     push    1
     mov     eax, [ebp+var_4]
     call    @@LStrToPChar   ; ::'intcls'::LStrToPChar
     mov     edx, eax
     mov     ecx, offset aButton1click
     mov     eax, ds:off_0_445CDC
     mov     eax, [eax]
     call    @TApplication@MessageBox ; TApplication::MessageBox
В общем-то, в этом коде нет ничего примечательного, но можно выяснить, что по адресу 00445CDCh находится указатель на экземпляр класса Application.
                xor     eax, eax
                pop     edx
                pop     ecx
                pop     ecx
                mov     fs:[eax], edx
                push    offset loc_0_4442B7

loc_0_444292:                           ; CODE XREF: CODE:004442B5 j
                lea     eax, [ebp+var_10]
                call    @@LStrClr       ; ::`intcls'::LStrClr
                lea     eax, [ebp+var_C]
                call    @@LStrClr       ; ::`intcls'::LStrClr
                lea     eax, [ebp+var_8]
                mov     edx, 2
                call    @@LStrArrayClr  ; ::`intcls'::LStrArrayClr
                retn
...
offset loc_0_4442B7:
                pop     ebx
                mov     esp, ebp
                pop     ebp
                retn
Рассмотрим восстановление стека подробнее. В стеке в настоящий момент содержится:
  • FS:[0]
  • указатель на finally-функцию
  • EBP - прежнее значение стека
  • EBX
  • ECX = 0
  • ECX = 0
  • ECX = 0
  • ECX = 0
  • оригинальное значение EBP
  • адрес возврата из функции
Хотя перед этим в стек была помещена 1 - её нет в стеке. Почему? Потому что она является последним аргументом функции TApplication::MessageBox(). Но ведь у этой функции всего три аргумента, и они все передаются в регистрах - скажете Вы! Ничего подобного, Вы забыли, что всем методам классов передаётся неявно ещё один аргумент (под номером ноль) - указатель на экземпляр класса. При возврате же вызываемая функция сама производит очистку стека.

Итак, сначала извлекается предыдущее значение FS:[0], указатель на finally-функцию и прежнее значение стека, и восстанавливается значение FS:[0]. Дальше в стек помещается адрес процедуры очистки стека. После инструкции retn стек будет выглядеть так:

  • EBX
  • ECX = 0
  • ECX = 0
  • ECX = 0
  • ECX = 0
  • оригинальное значение EBP
  • адрес возврата из функции
Далее снимается оригинальное значение регистра EBX, стек восстанавливается в первоначальное состояние (которое хранилось всё время выполнения процедуры в регистре EBP). Стек сейчас выглядит так:
  • оригинальное значение EBP
  • адрес возврата функции
Восстанавливается предыдущее значение регистра EBP (указатель стека для вызывающей процедуры) и после инструкции retn мы возвращаемся в вызывающую функцию с полностью восстановленным стеком.

Button2Click

Button2Click    proc near
                push    ebx
                push    esi
                mov     ebx, eax ; в eax - указатель на экземпляр класса
                push    0
                mov     cx, ds:word_0_44431C
                mov     dl, 3
                mov     eax, offset aButton2click_0
                call    @MessageDlg
                mov     esi, [ebx+2C4h] ; смещение на Edit1
                mov     eax, esi
                mov     edx, [eax]
                call    dword ptr [edx+50h] ; вызов TEdit::GetEnabled
                mov     edx, eax	; результат в eax
                xor     dl, 1		; xor boolean с 1 - его же not
                mov     eax, esi
                mov     ecx, [eax]
                call    dword ptr [ecx+60h] ; вызов TEdit::SetEnabled
                mov     esi, [ebx+2D4h] ; смещение на Button3
                mov     eax, esi
                mov     edx, [eax]
                call    dword ptr [edx+50h]
                mov     edx, eax
                xor     dl, 1
                mov     eax, esi
                mov     ecx, [eax]
                call    dword ptr [ecx+60h]
                pop     esi
                pop     ebx
                retn
Button2Click    endp
Эта функция инвертирует свойство Enabled поля ввода и кнопки. Свойство Enabled определено для класса TComponent (общий предок для TEdit и TButton) так:

property Enabled: Boolean read GetEnabled write SetEnabled
stored IsEnabledStored default True;

Доступ к этому свойству осуществляется через методы GetEnabled & SetEnabled, что мы и видим здесь - через индекс в VTBL.

Часть 2. Обработка исключений и сообщений

Итак, продолжим. На сей раз я наваял приложение, использующее несколько более продвинутые технологии, предоставляемые Delphi - exceptions handling ( перехват исключений ), virtual & dynamic функции, обработку формой сообщений Windows, производные классы и загрузку строковых ресурсов из реестра. Исходный код моей программы мог бы выглядеть как-нибудь так:

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TRPEnum = ( RP_One, RP_Two, RP_Tree );
TRPEnumSet = set of TRPEnum;

TRPException = class(Exception)
private
RP_Array: array[7..9] of string;
Code: TRPEnumSet;
public
Procedure Old_one_virtual; virtual;
Procedure Old_one_dynamic; dynamic;
Constructor Create;
Destructor Destroy; override;
end;

TRPExceptionChild = class(TRPException)
Procedure Old_one_virtual; override;
Procedure Old_one_dynamic; override;
end;

TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FDesignedWidth, FDesignedHeight: Integer;
procedure BuggyOne;
Procedure WMSizing( var Message: TMessage ); message WM_SIZING;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

resourcestring
BuggyOneCaption = 'BuggyOne';
MalformedException = 'Malformed exception';

(* TRPException *)
Constructor TRPException.Create;
begin
Application.MessageBox('Create', 'TRPException', ID_OK);
inherited Create('BuggyOne object');
end;

Destructor TRPException.Destroy;
begin
Application.MessageBox('Destroy', 'TRPException', ID_OK);
Inherited;
end;

Procedure TRPException.Old_one_virtual;
begin
Application.MessageBox('Old_one_virtual','TRPException', ID_OK);
end;

Procedure TRPException.Old_one_dynamic;
begin
Application.MessageBox('Old_one_dynamic','TRPException', ID_OK);
end;

(* TRPExceptionChild *)
Procedure TRPExceptionChild.Old_one_virtual;
begin
Application.MessageBox('Old_one_virtual','TRPExceptionChild', ID_OK);
end;

Procedure TRPExceptionChild.Old_one_dynamic;
begin
Application.MessageBox('Old_one_dynamic','TRPExceptionChild', ID_OK);
end;

(* TForm1 *)
procedure TForm1.BuggyOne;
var
RP_E: TRPExceptionChild;
N: Integer;
begin
MessageDlg(BuggyOneCaption,mtConfirmation,[mbOk],0);
try
RP_E := TRPExceptionChild.Create;
RP_E.Code := [RP_One];
RP_E.RP_Array[7] := 'Seven';
N := 9;
RP_E.RP_Array[8] := 'Eight';
RP_E.RP_Array[N] := 'Nine inch nails';
RP_E.Code := RP_E.Code + [RP_Two];
Raise RP_E;
MessageDlg('Not will showed at the end',mtConfirmation,[mbOk],0);
finally
MessageDlg('In finally part',mtConfirmation,[mbOk],0);
end;
MessageDlg('Not will showed at the end',mtConfirmation,[mbOk],0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
MessageDlg('Button1Click',mtConfirmation,[mbOk],0);
try
BuggyOne;
except
on E:TRPException do
begin
MessageDlg('Button1Click in exception block',mtConfirmation,[mbOk],0);
E.Old_one_virtual;
E.Old_one_dynamic;
end;
on E:TRPExceptionChild do
begin
MessageDlg(MalformedException,mtConfirmation,[mbOk],0);
end;
end;
MessageDlg('Button1Click at the end',mtConfirmation,[mbOk],0);
end;

Procedure TForm1.WMSizing( var Message: TMessage );
var
PRect : ^TRect;
Begin
PRect := Pointer (Message . LParam );
if PRect^. Right - PRect^. Left < FDesignedWidth then
begin
if Message.WParam in [ WMSZ_BOTTOMLEFT, WMSZ_LEFT, WMSZ_TOPLEFT ]
then
PRect^.Left := PRect^ . Right - FDesignedWidth
else
PRect^.Right := PRect^ . Left + FDesignedWidth;
end;
if PRect^ . Bottom - Prect^.Top < FDesignedHeight then
begin
if Message . WParam in [ WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT ]
then
PRect^.Top := PRect^ . Bottom - FDesignedHeight
else
PRect^. Bottom := PRect^ . Top + FDesignedHeight;
end;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
FDesignedWidth := Width;
FDesignedHeight := Height;
MessageDlg('FormCreate',mtConfirmation,[mbOk],0);
end;

Не вершина программистского мастерства, конечно, но для наших целей вполне годится. Итак, запустим дизассемблер ( я использовал IDA 3.8b ) и не забудьте применить файл сигнатур для библиотеки VCL версии 4 ( d4vcl ) - в моём случае IDA опознала 2172 функции.

А пока IDA делает грязную работу за нас, можно предаться чтению документации ( весьма рекомендую заниматься этим время от времени - можно узнать столько интересного :-). Итак, что мы можем узнать из официальной документации по Delphi о тонкой разнице между динамическими (dynamic) и виртуальными (virtual) методами ?

Virtual методы расположены в таблице виртуальных методах, по традиции называемой VTBL, которая дублируется для каждого производного класса. Если в производном классе переопределяется новый метод, указатель на него будет в этой таблице под тем же индексом, что и в VTBL класса-предка - но указывать он будет на перегруженный метод. За счёт этого достигается наилучшая скорость - вызов функции по указателю через смещение в VTBL. С другой стороны, для каждого нового класса полностью дублируется вся VTBL ! Короче, классический случай ножниц "скорость против размера".

Dynamic методы имеют несколько другой способ хранения. Им назначается некоторый индекс - но не в таблице, а в hash-структуре. Также эта структура не дублируется для каждого производного класса - если переопределяется dynamic метод, он переопределяется для данного класса - и всё. Но вызов dynamic методов имеет больше накладных расходов - при вызове Delphi просматривает все классы-предки данного класса в поисках метода с нужным индексом.

Посмотрим, как всё вышесказанное выглядит на Ассемблере:

Я надеюсь, Вы ещё помните, насколько полезна бывает RTTI ? RTTI класса нашей единственной формы расположена по адресу 0x44016C. На сей раз она содержит по смещению 1Ch ненулевое значение, а указатель на hash-массив dynamic методов. Структура эта имеет примерно такой вид:

Структура RTTI класса TForm1
Смещение | Тип | Описание
0 | WORD | Размер N hashа
2 | WORD | индексов dynamic методов
N * 2 + 2 | DWORD | N указателей на функции

Что ещё более интересно, в нашём случае индекс единственной функции - WMSizing 0x214. Если Вы посмотрите в файле заголовков messages.pas, 0x214 ( eq 532 ) есть значение сообщения WM_SIZING. В Borlandе, видимо, простые парни работают...

Итак, сейчас у нас есть более полное описание RTTI, я позволю себе повторить его здесь полностью:

Более полное описание RTTI
Смещение | Тип | Описание
0 | DWORD | указатель на VTBL
4 | DWORD | значение не выяснено (vmtIntfTable)
8 | DWORD | значение не выяснено (vmtAutoTable)
Ch | DWORD | значение не выяснено (vmtInitTable)
10h | DWORD | указатель на список наследований
14h | DWORD | указатель на компоненты, которыми владеет данный класс
18h | DWORD | указатель на массив обработчиков событий
1Ch | DWORD | указатель на hash dynamic методов
20h | DWORD | указатель на Pascal-строку - имя класса
24h | DWORD | размер класса
28h | DWORD | указатель на структуру RTTI класса-предка данного класса
2Ch | DWORD | указатель на метод SafeCallException
30h | DWORD | указатель на метод AfterConstruction
34h | DWORD | указатель на метод BeforeDestruction
38h | DWORD | указатель на метод Dispatch
3Ch | DWORD | указатель на метод DefaultHandler
40h | DWORD | указатель на метод NewInstance
44h | DWORD | указатель на метод FreeInstance
48h | DWORD | указатель на метод Destroy
4Ch | DWORDs | начало VTBL

Давайте рассмотрим самую примечательную функцию в моей программе - TForm1.Button1Click. Примечательна она исключительно тем, что вызывает функцию BuggyOne, выбрасывающую исключение, которое затем сама же и ловит двумя руками.

BuggyOne        proc near

var_4           = dword ptr -4

                push    ebp
                mov     ebp, esp
                push    0	; инициализация в 0 var_4
                push    ebx	; сохранить ebx
                push    esi	; и esi
                xor     eax, eax
                push    ebp     ; и ещё ebp
                push    offset loc_0_44064F	; поместим в стек адрес
                        ; finally кода
                push    dword ptr fs:[eax]      ; и прежнее значение стека
                        ; обработки исключений
                mov     fs:[eax], esp		; в стек обработки исключений
                 ; помещается указатель на текущее значение стека
                push    0
                lea     edx, [ebp+var_4]	; загрузим в var_4 строку из
                mov     eax, offset off_0_440368	; ресурсов
                call    @LoadResString
...
loc_0_440646:
                lea     eax, [ebp+var_4]	; очистить строку в var_4
                call    @@LStrClr       ; ::`intcls'::LStrClr
                retn
; ------------------------------------------------------------------
loc_0_44064F:
                jmp     @@HandleFinally ; ::`intcls'::HandleFinally
; ------------------------------------------------------------------
                jmp     short loc_0_440646
Обратите внимание на две вещи:
  1. инициализация стека исключений. В стек помещается указатель 0x44064f, далее значение стека заносится с fs:[0]. По адресу 0x44064f нет ничего примечательного - просто переход на одинаковый для всех кусок кода HandleFinally. Но вот сразу за ним идёт код, который, казалось бы, никогда не достигается - переход на 0x440646. Но вот этот-то код как раз и есть finally часть в обработке исключений. В данном случае - это освобождение строки var_4.

    HandleFinally:

    @@HandleFinally:
         mov     eax, [esp+4]
         mov     edx, [esp+8]
         test    dword ptr [eax+4], 6
         jz      short loc_0_403294
         mov     ecx, [edx+4]	; адрес перехода на HandleFinally
         mov     dword ptr [edx+4], offset loc_0_403294
         push    ebx
         push    esi
         push    edi
         push    ebp
         mov     ebp, [edx+8]
         add     ecx, 5          ; добавим к нему 5
         call    @System@_16583  ; System::_16583
         call    ecx		; и вызовем как функцию
         pop     ebp
         pop     edi
         pop     esi
         pop     ebx
loc_0_403294:
         mov     eax, 1
         retn
    На момент вылета на этот код в fs:[0] и eax содержится указатель стека, в котором находятся ранее занесённые в него ( смотрите начало процедуры BuggyOne; также я привык изображать вершину стека сверху, а не как оно есть на самом деле ):

    • [eax + 4] прежнее значение стека в fs:[0]
    • [eax + 8] указатель на инструкцию перехода к HandleFinally
    • [eax + 0xC] ebp

    Т.е. происходит следующее - инструкция следом за переходом на HandleFinally является процедурой обработки finally-части ( так как размер инструкции "jmp HandleFinally" равен ровно 5 байт )

  2. Загрузка строки из ресурса. Строка BuggyOneCaption описана как resourcestring - это значит, что Delphi помесила её в строковую таблицу. Прототип функции LoadResString ( из Sys/System.pas ):

    type
    PResStringRec = ^TResStringRec;
    TResStringRec = record
    Module: ^Longint;
    Identifier: Integer;
    end;

    function LoadResString(ResStringRec: PResStringRec): string;

    Module - handler загруженного модуля, содержащего в себе ресурс. Для нашей программы это hInstance самого приложения ( поскольку главная форма находится в том же модуле, что и объект TApplication ).

    Identifier - целое число, меньшее 65536, или указатель на LPSZ строку - имя ресурса. По адресу 0x440368 содержится:

    off_0_440368    dd offset dword_0_4424D8 ; hModule приложения
                dd 0FF5Dh		 ; Identifier
    Число 0xFF5D = 65373 < 65536, так что наша строка идентифицируется по числовому значению. Посмотрим ресурсы моей программы в редакторе ресурсов Restorator ( кстати, весьма рекомендую эту программу для исследований приложений на Delphi - она умеет показывать описание Delphi-форм ! ). Наша строка нашлась в секции string tables под номером секции 4086, смещение -3. Как это соотносится с ранее найденным значением идентификатора ? Очень просто:
    65373 = 4086 * 16 - 3;
    Всё гениальное просто ( однако не всё простое гениально ).
          xor     eax, eax
      push    ebp
      push    offset loc_0_44061D  ; новый finally handler
      push    dword ptr fs:[eax]
      mov     fs:[eax], esp
      mov     dl, 1
      mov     eax, ds:off_0_44016C ; ptr to TRPExceptionChild RTTI
      call    sub_0_440378         ; TRPExceptionChild::Create
      mov     ebx, eax
      mov     al, ds:byte_0_440660 ; db 1 eq RP_One из TRPEnum
      mov     [ebx+18h], al
      lea     eax, [ebx+0Ch]
      mov     edx, offset aSeven   ; "Seven"
      call    @@LStrAsg       ; ::`intcls'::LStrAsg
      mov     esi, 9
      lea     eax, [ebx+10h]
      mov     edx, offset aEight   ; "Eight"
      call    @@LStrAsg       ; ::`intcls'::LStrAsg
      lea     eax, [ebx+esi*4-10h]
      mov     edx, offset aNineInchNails	; "Nine inch nails"
      call    @@LStrAsg       ; ::`intcls'::LStrAsg
      mov     al, [ebx+18h]
      or      al, ds:byte_0_44069C ; db 2 eq RP_Two из TRPEnum
      mov     [ebx+18h], al
      mov     eax, ebx
      call    @@RaiseExcept   ; ::`intcls'::RaiseExcept
...
loc_0_44061D:
      jmp     @@HandleFinally
; ----------------------------------------
      jmp     short loc_0_440607
...
loc_0_440607:
      push    0
      mov     cx, ds:word_0_44065C
      mov     dl, 3
      mov     eax, offset aInFinallyPart
      call    @MessageDlg
      retn
    Дальше совсем просто. Инициализируется новый обработчик finally части, при этом указатель на старое значение стека также помещается в стек. Далее вызывается конструктор TRPExceptionChild::Create - первым аргументом ему передаётся указатель на RTTI класса TRPExceptionChild, а вторым ( в регистре dl, я не знаю для чего ) 1 - указатель на созданный экземпляр класса возвращается в регистре eax, и затем пересылается в ebx, который используется в дальнейшем как базовый регистр. Члену Code присваивается значение RP_One ( eq 1 ) из набора TRPEnum. Можно заметить, что Code расположена в классе TRPException по смещению 0x18h. Затем идёт присваивание значений массиву строк - массив начинается по смещению 0xC. Довольно непонятно выглядит присваивание последнему ( 9ому элементу массива ): он должен быть расположен по смещению 0xC + (3 - 1) * 4 = 0x14; 9 * 4 - 0x10 даёт то же самое 0x14, но какова логика ! Затем к нашему набору Code добавляется RP_Two ( eq 2 ). Потом вызывается процедура RaiseExcept с единственным аргументом в eax - адресом нашего класса.

Пожалуй, в BuggyOne больше нет ничего интересного.

Button1Click

 ...
        push    offset loc_0_440728
        push    dword ptr fs:[edx]
        mov     fs:[edx], esp
        mov     eax, ebx
        call    BuggyOne	; процедура, генерирующая исключение
        xor     eax, eax
        pop     edx
        pop     ecx
        pop     ecx
        mov     fs:[eax], edx
        jmp     short loc_0_440790
; --------------------------------------------------------
loc_0_440728:
        jmp     @@HandleOnException ; ::`intcls'::HandleOnExceptions
; --------------------------------------------------------
        dd 2	; размер фильтров исключений
        dd offset off_0_4400F4  ; адрес RTTI TRPException
        dd offset loc_0_440741  ; адрес код для TRPException
        dd offset off_0_44016C  ; TRPExceptionChild
        dd offset loc_0_44076B  ; On TRPExceptionChild
; ----------------------------------------------------------------
loc_0_440741:
        mov     ebx, eax
        push    0
        mov     cx, ds:word_0_4407C8
        mov     dl, 3
        mov     eax, offset aButton1clickIn
        ; строка "Button1Click in exception block"
        call    @MessageDlg
        mov     eax, ebx
        mov     edx, [eax]	; вызов TRPExceptionChild::Old_one_virtual
        call    dword ptr [edx]
        mov     eax, ebx
        mov     bx, 0FFFFh	; вызов TRPExceptionChild::Old_one_dynamic
                ; имеет индекс 0xFFFF
        call    @@CallDynaInst  ; ::`intcls'::CallDynaInst
        jmp     short loc_0_44078B
Здесь можно увидеть в действии механизм фильтрации и обработки исключений. Опять в fs:[0] помещается указатель на стек, но на сей раз в него помещён адрес инструкции перехода к процедуре обработке исключений HandleOnExceptions. Следом за ней расположен массив фильтров исключений. Он имеет весьма незатейливую структуру:

Структура массива фильтров исключений
Смещение | Тип | Описание
0 | DWORD | Размер N массива фильтров исключений
4 | DWORD | Указатель на RTTI класса - объекта исключение
8 | DWORD | Указатель на код, вызываемый при исключении этого класса
4 + M * 4 | DWORD | Указатель на M-ную RTTI класса - объекта исключение
8 + M * 4 | DWORD | Указатель на код, вызываемый при исключении M-ного класса

Далее мы можем наблюдать вызовы virtual & dynamic функций - соответственно, TRPExceptionChild::Old_one_virtual & TRPExceptionChild::Old_one_dynamic.

  1. Вызов TRPExceptionChild::Old_one_virtual
    Простой и понятный вызов функции по указателю. Первым членом любого класса идёт указатель на VTBL - по смещению 0x0; метод Old_one_virtual является единственным в VTBL класса TRPExceptionChild - соответственно, он расположен под индексом 0. Под тем же самым индексом в VTBL класса TRPException расположен виртуальный метод TRPException::Old_one_virtual

  2. Вызов TRPExceptionChild::Old_one_dynamic
    В hash dynamic методов класса TRPException метод TRPException::Old_one_dynamic прописан под индексом 0xFFFF. Сложно сказать, что будет, если, имея dynamic метод с индексом 0xFFFF, Вы попробуете обработать событие Windows с номеров 0xFFFF ( можете попробовать сделать это самостоятельно ). Остаётся надеятся, что Delphi всё-таки отслеживают занятые индексы для динамических методов.
Как видите, для вызова динамических методов используется вызов функции CallDynaInst с передаваемым в регистре bx индексом метода.

Приложение A

Поскольку я человек ленивый ( лень - двигатель прогресса ) и мне совершенно не хотелось вручную сообщать IDA Pro, что это не просто нечто бесформенное, а самая что ни наесть структура RTTI ( при этом ещё мучительно вспоминая, чего там идёт под каким смещением ), я написал небольшой script на IDC, который позволяет мне иметь немного свободного времени для прямых обязанностей сисадмина, а именно - для чтения newsов и взлома программ...

/*
 * This script deal with Delphi RTTI structures
 *
 * 	Red Plait, 23-VIII-1999
 */
#include

// makes dword and offset to data
static MakeOffset(adr)
{
  auto ref_adr;

  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeUnkn(adr+2,0);
  MakeUnkn(adr+3,0);
  MakeDword(adr);
  ref_adr = Dword(adr);
  if ( ref_adr != 0 )
   add_dref(adr, ref_adr, 0);
}

// makes dword and offset to a function
static MakeFOffset(adr,string)
{
  auto ref_adr, func_name;
  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeUnkn(adr+2,0);
  MakeUnkn(adr+3,0);
  MakeDword(adr);
  ref_adr = Dword(adr);
  if ( ref_adr != 0 )
  {
    MakeFunction(ref_adr, BADADDR);
    MakeName(ref_adr,string);
    add_dref(adr,ref_adr,0);
  }
}

// makes simple string
static do_Str(adr,len)
{
 auto count;
 for ( count = 0; count < len; count++ )
  MakeUnkn(adr + count,0);
 MakeStr(adr, adr+len);
}

// makes Pascal-style string
static makePStr(adr)
{
 auto len;
 MakeUnkn(adr,0);
 MakeByte(adr);
 len = Byte(adr);
 do_Str(adr+1,len);
 return len + 1;
}

// extract pascal-style string
static getPStr(adr)
{
 auto len, res, c;

 len = Byte(adr++);
 res = "";
 for ( ; len; len-- )
 {
   c = Byte(adr++);
   res = res + c;
 }
 return res;
}

// returns name of class of this RTTI
static getRTTIName(adr)
{
  auto ptr;
  ptr = Dword(adr+0x20);
  if ( ptr != 0 )
   return getPStr(ptr);
  else
   return "";
}

// processing owned components list
static processOwned(adr)
{
 auto count, str_len, comp_count, rtti_base;

 MakeUnkn(adr,0);
 MakeUnkn(adr+1,0);
 MakeWord(adr);
 comp_count = Word(adr); /* count of RTTI array */
 adr = adr + 2;
 MakeOffset(adr);
 rtti_base = Dword(adr); /* offset to array of RTTI */
 adr = adr + 4;
 /* process RTTI array */
 MakeUnkn(rtti_base,0);
 MakeUnkn(rtti_base+1,0);
 MakeWord(rtti_base);    /* size of array */
 count = Word(rtti_base);
 rtti_base = rtti_base + 2;
 for ( str_len = 0; str_len < count; str_len++ )
 {
   MakeOffset(rtti_base + str_len * 4);
 }
 /* process each of owned to form components */
 for ( count = 0; count < comp_count; count++ )
 {
  // offset in owners class
   MakeUnkn(adr,0);
   MakeUnkn(adr+1,0);
   MakeWord(adr);
   str_len = Word(adr);
   MakeComm(adr, "Offset 0x" + ltoa(str_len,0x10) );
   adr = adr + 2;
  // unknow word
   MakeUnkn(adr,0);
   MakeUnkn(adr+1,0);
   MakeWord(adr);
   adr = adr + 2;
  // index in RTTI array
   MakeUnkn(adr,0);
   MakeUnkn(adr+1,0);
   MakeWord(adr);
   str_len = Word(adr);
   MakeComm(adr, "Type: " + getRTTIName(Dword(rtti_base + str_len*4)) );
   adr = adr + 2;
  // pascal string - name of component
   MakeUnkn(adr,0);
   str_len = Byte(adr);
   adr = adr + 1;
   do_Str(adr,str_len);
   adr = adr + str_len;
 }
}

// process events handlers list
static processHandlers(adr)
{
 auto count, str_len, f_addr;

 MakeUnkn(adr,0);
 MakeUnkn(adr+1,0);
 MakeWord(adr);
 MakeComm(adr,"Handlers count");
 count = Word(adr);
 adr = adr + 2;
 for ( ; count; count-- )
 {
 // unknown dword
  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeWord(adr);
  adr = adr + 2;
 // offset to function - handler
  f_addr = Dword(adr);
  MakeOffset(adr);
  adr = adr + 4;
 // Name of handler
  if ( f_addr != 0 )
  {
    MakeCode(f_addr);
    MakeFunction(f_addr, BADADDR);
    MakeName(f_addr, getPStr(adr));
  }
  adr = adr + makePStr(adr);
 }
}

// process inherited list first element ( may be recursive ? )
// returns pointer to next parent`s struct
static processParent(adr)
{
  auto str_len;
  auto res;

  res = 0;
 // 1st byte - unknown
  MakeUnkn(adr,0);
  MakeByte(adr);
  adr = adr + 1;
 // next - Pascal string - name of class
  adr = adr + makePStr(adr);
 // VTBL pointer
  MakeOffset(adr);
  adr = adr + 4;
 // next - pointer to pointer to next this struct :-)
  MakeOffset(adr);
  str_len = Dword(adr);
  if ( str_len != 0 )
  {
   MakeOffset(str_len);
   res = Dword(str_len);
  }
  adr = adr + 4;
 // WORD - unknown
  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeWord(adr);
  adr = adr + 2;
 // next - name of Unit name
  makePStr(adr);
  return res;
}

// process dynamic methods table
static processDynamic(adr)
{
  auto count, base, i, old_comm;

  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeWord(adr);
  count = Word(adr);
  MakeComm(adr,"Count of dynamic methods " + ltoa(count,10) );
  adr = adr + 2;
  base = adr + 2 * count;
  for ( i = 0; i < count; i++ )
  {
    MakeUnkn(adr,0);
    MakeUnkn(adr+1,0);
    MakeWord(adr);
    MakeOffset(base + 4 * i);
    old_comm = Comment(base + 4 * i);
    if ( old_comm != "" )
     MakeComm(base + 4 * i, "Dynamic 0x" + ltoa(Word(adr),0x10) + ", " + old_comm );
    else
     MakeComm(base + 4 * i, "Dynamic 0x" + ltoa(Word(adr),0x10) );
    adr = adr + 2;
  }
  return count;
}

// makes tricky VTBL entries
static makeF2Offset(adr,name)
{
 auto comm,ref_adr;

 MakeOffset(adr);
 ref_adr = Dword(adr);
 if ( ref_adr != 0 )
    add_dref(adr,ref_adr,0);
 comm = Comment(adr);
 if ( comm != "" )
  MakeComm(adr, comm + ", " + name);
 else
  MakeComm(adr, name);
}

// main function - process RTTI structure
static processRTTI(adr)
{
 auto count;
 auto res;
 auto my_name;

 my_name = "";
 // first DWORD - VTBL pointer
 MakeOffset(adr);
 // three next DWORD is unknown
 MakeOffset(adr+4);
 MakeOffset(adr+8);
 MakeOffset(adr+0xc);
 // list of parents
 MakeOffset(adr+0x10);
 count = Dword(adr+0x10);
 if ( count != 0 )       // also process first parent for this class
  processParent(count);
 // 0x14 DWORD - owned components
 MakeOffset(adr+0x14);
 count = Dword(adr+0x14);
 if ( count != 0 )
  processOwned(count);
 // 0x18 DWORD - event handlers list
 MakeOffset(adr+0x18);
 count = Dword(adr+0x18);
 if ( count != 0 )
  processHandlers(count);
 // 0x1c DWORD - pointer to dynamic functions list
 MakeOffset(adr+0x1c);
 count = Dword(adr+0x1c);
 if ( count != 0 )
 {
  count = processDynamic(count);
  MakeComm(adr+0x1c, ltoa(count,10) + " dynamic method(s)");
 }
 // 0x20 DWORD - pointer to class name
 MakeOffset(adr+0x20);
 count = Dword(adr+0x20);
 if ( count != 0 )
 {
   makePStr(count);
   my_name = getPStr(count);
   MakeComm(adr+0x20, "Name: " + my_name );
 }
 // 0x24 DWORD - size of class
 MakeUnkn(adr+0x24,0);
 MakeUnkn(adr+0x25,0);
 MakeUnkn(adr+0x26,0);
 MakeUnkn(adr+0x27,0);
 MakeDword(adr+0x24);
 MakeComm(adr+0x24,"Size of class");
 // 0x28 - pointer to parent`s RTTI struct
 MakeOffset(adr+0x28);
 res = Dword(adr+0x28);
 MakeComm(adr+0x28,"Parent`s class");
 // 0x2c SafeCallException
 makeF2Offset(adr+0x2c,my_name + "::SafeCallException");
 // 0x30 AfterConstruction
 makeF2Offset(adr+0x30,my_name + "::AfterConstruction");
 // 0x34 BeforeConstruction
 makeF2Offset(adr+0x34,my_name + "::BeforeConstruction");
 // 0x38 Dispatch
 makeF2Offset(adr+0x38,my_name + "::Dispatch");
 // 0x3C DefaultHandler
 makeF2Offset(adr+0x3c,my_name + "::DefaultHandler");
 // 0x40 NewInstance
 makeF2Offset(adr+0x40,my_name + "::NewInstance");
 // 0x44 FreeInstance
 makeF2Offset(adr+0x44,my_name + "::FreeInstance");
 // 0x48 Destroy
 makeF2Offset(adr+0x48,my_name + "::Destroy");
 return res;
}
Пояснения по каждой функции:
  • MakeOffset создаёт смещение по указанному адресу adr. Иногда IDA бывает упряма, и настаивает, что по этому адресу вовсе не смещение, а, скажем, data - четырёх вызовов MakeUnkn обычно бывает достаточно, чтобы изменить её мнение
  • MakeFOffset - аналогично MakeOffset, но только создаёт смещение на функцию, которую называет string. Warning: не проверяется результат MakeFunction, поэтому функция может быть не совсем правильной. В любом случае, это нужно проверять обычно.
  • do_Str - помечает len байт с адреса adr как строку
  • makePStr - создаёт pascal-строку по адресу adr. Возвращает её длину, включая сам байт длины.
  • getPStr - возвращает значение pascal-строки по адресу adr.
  • getRTTIName - возвращает имя класса по его RTTI, расположенной по адресу adr
  • processOwned - обрабатывает список компонентов, принадлежащих данному компоненту. Сам список начинается с адреса adr
  • processHandlers - обрабатывает список функций-обработчиков событий. Сам список начинается с адреса adr. Warning: так как имеет место попытка назвать функцию так же, как она называлась в этом классе, имя может быть неуникально ( вспомните, сколько раз у Вас были функции с именем Button1Click в разных классах )
  • processParent - обрабатывает один элемент в списке наследований по адресу adr. Это рекурсивная структура, но её окончание может быть обозначено по-разному - либо как Nil, либо как две структуры TObject, ссылающиеся друг на друга. На всякий случай возвращается ссылка на следующий элемент.
  • processDynamic - обрабатывает hash динамических методов по адресу adr. Warning: несмотря на то, что этот метод пытается сохранить ранее данные комментарии для указателя на каждую dynamic функцию, похоже, что в IDA Pro есть bug, из-за которого нельзя извлечь комментарии для опознанных с помощью сигнатур функций ( который по умолчанию имеют тёмно-коричневый цвет, скажем, TFormCustom::WMPaint ). Вызов Comment на таких комментариях возвращает пустую строку. Возвращается число динамических функций.
  • makeF2Offset - вспомогательная функция, служит по пометки служебных функций ( с отрицательным индексом в VTBL ) и добавления к ним комментария. Адрес функции передаётся в adr, строка комментария в name
  • processRTTI - собственно, самая главная функция, собирающая все остальные - обрабатывает структуру RTTI по адресу adr
Я даже в кои-то веки раз комментарии кое-где сделал, так что я надеюсь, Вам не составит труда разобраться в моих каракулях.

Часть 3. Интерфейсы и 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, чтобы он поддерживал все обнаруженные структуры. Cам script приведен в конце данной статьи.

IDC script для анализа RTTI Delphi 4

IDC script для анализа RTTI Delphi 4

Текущая версия 0.2.
Тестировалась на трёх отладочных приложениях и одном реальном ( размером порядка 3 Mb ). Во время тестирования не были проверены published-свойства в виде интерфейсов.

Описание функций

Перечислены в том же порядке, в котором они следуют в файле d4rtti.idc.

  • setComment(adr,set_to,is_before)
    Вставляет строку set_to комментария по адресу adr. Поскольку функции этого scriptа могут прогоняться несколько раз над одним и тем же адресом, производится проверка, был ли уже вставлен данный комментарий. Параметр is_before определяет, как нужно поместить вновь вставляемый комментарий - до уже имеющегося или после.
  • ReMakeByte(adr)
    Помечает данные по адресу adr как байт и возвращает его значение.
  • ReMakeInt(adr)
    Помечает данные по адресу adr как двойное слово и возвращает его значение.
  • ReMakeWord(adr)
    Помечает данные по адресу adr как слово и возвращает его значение.
  • ReMakeQword(adr)
    Помечает данные по адресу adr как QWORD и возвращает его значение.
  • MakeOffset(adr)
    Помечает данные по адресу adr как смещение и возвращает его значение.
  • ReMakeFunc(adr)
    Пытается преобразовать данные по адресу adr в функцию. Не гарантирует правильного опознавания всего кода функции.
  • MakeFOffset(adr)
    Помечает данные по адресу adr как смещение на функцию и пытается преобразовать данные по этому смещению в функцию. Замечания аналогично предыдущей функции.
  • MakeNameFOffset(adr,name)
    Помечает данные по адресу adr как смещение на функцию и пытается преобразовать данные по этому смещению в функцию, которую переименует в name. Замечания аналогичны ReMakeFunc
  • ReMakeStr(adr,len)
    Помечает данные по адресу adr длиной len как строку.
  • makePStr(adr)
    Помечает данные по адресу adr как pascal-style строку. Возвращает длину этой строки.
  • getPStr(adr)
    Возвращает pascal-style строку по адресу adr.
  • getRTTIName(adr)
    Возвращает имя класса, чья RTTI содержится по адресу adr.
  • getOwnedCount(adr)
    Возвращает количество структур RTTI для списка субкомпонентов, расположенного по адресу adr.
  • processOwned(adr)
    Обрабатывает список субкомпонентов, расположенный по адресу adr. Возвращает адрес массива структур RTTI для этих субкомпонентов. Поскольку я не смог вызвать на IDC функцию, описанную позже, чем её вызов, рекурсивная обработка RTTI здесь не используется. Вместо этого эти структуры RTTI обрабатываются позже в _processRTTI.
  • processHandlers(adr,class_name)
    Обрабатывает таблицу обработчиков событий по адресу adr для класса с именем class_name. Для всех функций-обработчиков в качестве префикса добавляется имя class_name ( для обеспечения уникальности этих имён ).
  • get_type_name(adr)
    Возвращает имя типа для структуры TypeInfo по адресу adr.
  • TypeOrdComm(Ord)
    Возвращает строковое название размера простого типа данных Ord.
  • TypeOrdKind(Ord)
    Возвращает строковое название типа данных Ord.
  • TypeOrdFloat(Ord)
    Возвращает строковое название размера для типов данных с плавающей точкой Ord.
  • doParamFlag(Set)
    Возвращает в виде строки представление набора атрибутов Set параметра функций и процедур.
  • doIntfFlag(Set)
    Возвращает в виде строки представление набора атрибутов Set интерфейса.
  • TypeOrdMethod(Ord)
    Возвращает строковое название типа метода Ord.
  • processTypeInfo(adr)
    Обрабатывает структуру TypeInfo по адресу adr.
    Предупреждения относительно этой функции:
    1. Не производится рекурсивная обработка поля BaseType для типа tkEnumeration. Причиной это служит зацикливание (если тип tkEnumeration не наследует ни от какого набора, это полу указывает на свою же структуру TypeData).
    2. Для типа tkClass не производится рекурсивной обработки структуры RTTI ClassType. Это сделано для предотвращения зацикливаний ( если, скажем, свойством некоторого класса будет указатель на тот же самый класс ), также см. примечание к функции processOwned.
    3. По вышеназванным причинам не производится обработка структуры ParentInfo (указатель на TypeInfo предка) и PropData (рекурсивная структура TypeInfo) для типа tkClass.
    4. Поскольку у меня не было published-свойств - интерфейсов, обработка типа tkInterface не производится.
  • separatePointer(base_adr, adr, kind)
    Возвращает строковое описание метода в атрибутах published-свойств. Адрес RTTI класса передаётся в base_adr, адрес атрибута в adr, строка с описанием класса атрибута в kind.
  • doPublished(adr, base_adr)
    Обрабатывает published-свойства класса по адресу adr, RTTI класса находится по адресу base_adr. См. также предупреждения относительно функции processTypeInfo.
  • processDynamic(adr)
    Обрабатывает таблицу динамических методов по адресу adr. Динамические функции никак не называются.
  • makeF2Offset(adr,name)
    Помечает данные по адресу adr как указатель на функцию и вставляет комментарий name.
  • make_TGUID(adr)
    Помечает данные по адресу adr как GUID.
  • padZeros(str,desired_len)
    Увеличивает длину строки str до длины desired_len, дополняя её слева символов "0".
  • getTGUIDstr(adr)
    Возвращает строковое представление GUID по адресу adr.
  • processIntf(adr)
    Обрабатывает таблицу интерфейсов по адресу adr.
  • get_dyncount(adr)
    Возвращает число динамических методов для структуры RTTI по адресу adr.
  • _processRTTI(adr, is_recursive)
    Обрабатывает RTTI структуру по адресу adr. Флаг is_recursive предназначен для рекурсивной обработки всех связанных структур RTTI.
  • askRTTI(adr)
    Выдаёт приглашение на обработку структуры RTTI по адресу adr. В случае успеха возвращает 1.
  • processRTTI(adr)
    Обрабатывает RTTI структуру по адресу adr.
  • allRTTI(adr)
    Рекурсивно обрабатывает структуру RTTI по адресу adr.
Пример использования

В IDA Pro загрузить этот script ( нажатием F2 ). Далее, поместив курсор на адрес начала структуры RTTI, выполнить команду IDC:

 processRTTI(ScreenEA());
Предполагаемые улучшения
  • Поддержка published-свойств интрефейсного типа.
  • Поддержка сохранения информации о RTTI в текстовый файл (IMHO, значительно приятнее иметь подобного рода информацию для дальнейшего дизассемблирования в IDA Pro распечатанной на бумаге, нежели постоянно рыскать по структуре RTTI)
  • Функции для поддержки exceptions & system initialization
  • Здесь могут быть и Ваши предложения. Напишите автору по адресу redplait@usa.net
Файл d4rtti.idc
/*
 * This script deal with Delphi RTTI structures
 *
 * Created by Red Plait ( redplait@usa.net ), 23-VIII-1999
 * History:
 * 28-08-1999	RP	Added support for dynamic methods
 * 01-09-1999	RP	Added support for interfaces & eight methods in VTBL
 *			with negative indexes
 * 06-09-1999	RP	TypeInfo of published properties (rip some code from
 *			Santucco)
 */
#include

// consts for TypeInfo
#define tkUnknown       0
#define tkInteger       1
#define tkChar          2
#define tkEnumeration   3
#define tkFloat		4
#define tkString 	5
#define tkSet 		6
#define tkClass 	7
#define tkMethod	8
#define tkWChar		9
#define tkLString 	10
#define tkWString	11
#define tkVariant	12
#define tkArray		13
#define tkRecord	14
#define tkInterface	15
#define tkInt64		16
#define tkDynArray	17

// consts for OrdType
#define otSByte         0
#define otUByte         1
#define otSWord         2
#define otUWord         3
#define otSLong         4

// consts for FloatType
#define ftSingle        0
#define ftDouble        1
#define ftExtended      2
#define ftComp          3
#define ftCurr          4

// consts for MethodKind
#define mkProcedure	0
#define mkFunction	1
#define mkConstructor	2
#define mkDestructor	3
#define mkClassProcedure	4
#define mkClassFunction	5
#define mkSafeProcedure	6
#define mkSafeFunction	7

// consts for ParamFlag - set
#define pfVar		0
#define pfConst		1
#define pfArray		2
#define pfAddress	3
#define pfReference	4
#define pfOut		5

// consts for IntfFlag - set
#define ifHasGuid	0
#define ifDispInterface	1
#define ifDispatch	2

// do reenterable comments :-)
// Params:
//  adr		- address to comment
//  set_to	- comment to set
//  is_before	- place new comment before old
static setComment(adr,set_to,is_before)
{
 auto old_comm;

 if ( ! strlen(set_to) )
  return; // no comments
 old_comm = Comment(adr);
 if ( ! strlen(old_comm) )
 {
   MakeComm(adr, set_to);
   return;
 }
 if ( -1 != strstr(old_comm,set_to) )
  return;
 if ( is_before )
  MakeComm(adr,set_to + "," + old_comm);
 else
  MakeComm(adr,old_comm + "," + set_to);
}

// makes Byte
static ReMakeByte(adr)
{
  MakeUnkn(adr,0);
  MakeByte(adr);
  return Byte(adr);
}

// makes dword
static ReMakeInt(adr)
{
  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeUnkn(adr+2,0);
  MakeUnkn(adr+3,0);
  MakeDword(adr);
  return Dword(adr);
}

// makes word
static ReMakeWord(adr)
{
  MakeUnkn(adr,0);
  MakeUnkn(adr+1,0);
  MakeWord(adr);
  return Word(adr);
}

// makes qword
static ReMakeQword(adr)
{
 auto count;
 for ( count = 0; count < 8; count++ )
  MakeUnkn(adr + count, 0);
 MakeQword(adr);
 return Qword(adr);
}

// makes dword and offset to data
static MakeOffset(adr)
{
  auto ref_adr;

  ref_adr = ReMakeInt(adr);
  if ( ref_adr != 0 )
   add_dref(adr, ref_adr, 0);
  return ref_adr;
}

static ReMakeFunc(adr)
{
  if ( adr != 0 )
  {
    MakeUnkn(adr,1);
    MakeCode(adr);
    MakeFunction(adr, BADADDR);
  }
}

// makes dword and offset to a function
static MakeFOffset(adr)
{
  auto ref_adr;
  ref_adr = MakeOffset(adr);
  ReMakeFunc(ref_adr);
  return ref_adr;
}

// make offset to function and name it
static MakeNameFOffset(adr,name)
{
 auto ref_adr;

 ref_adr = MakeFOffset(adr);
 if ( ref_adr )
  MakeName(ref_adr,name);
}

// makes simple string
static ReMakeStr(adr,len)
{
 auto count;
 for ( count = 0; count < len; count++ )
  MakeUnkn(adr + count,0);
 MakeStr(adr, adr+len);
}

// makes Pascal-style string
// Returns lenght of pascal string (including byte for lenght)
static makePStr(adr)
{
 auto len;
 MakeUnkn(adr,0);
 len = ReMakeByte(adr);
 ReMakeStr(adr+1,len);
 return len + 1;
}

// extract pascal-style string
static getPStr(adr)
{
 auto len, res, c;

 len = Byte(adr++);
 res = "";
 for ( ; len; len-- )
 {
   c = Byte(adr++);
   res = res + c;
 }
 return res;
}

// returns name of class of this RTTI
static getRTTIName(adr)
{
  auto ptr;
  ptr = Dword(adr+0x20);
  if ( ptr != 0 )
   return getPStr(ptr);
  else
   return "";
}

static getOwnedCount(adr)
{
  return Word(Dword(adr+2)); // wow!
}

// processing owned components list
// Returns ptr to RTTI array (cauze I don`t know how to make forward declaration
//  of _processRTTI
static processOwned(adr)
{
 auto count, str_len, comp_count, rtti_base;

 comp_count = ReMakeWord(adr);  /* count of RTTI array */
 adr = adr + 2;
 rtti_base = MakeOffset(adr);	/* offset to array of RTTI */
 adr = adr + 4;
 /* process RTTI array */
 count = ReMakeWord(rtti_base);	/* size of array */
 rtti_base = rtti_base + 2;
 for ( str_len = 0; str_len < count; str_len++ )
 {
   MakeOffset(rtti_base + str_len * 4);
 }
 /* process each of owned to form components */
 for ( count = 0; count < comp_count; count++ )
 {
  // offset in owners class
   str_len = ReMakeWord(adr);
   setComment(adr, "Offset 0x" + ltoa(str_len,0x10), 1);
   adr = adr + 2;
  // unknow word
   ReMakeWord(adr);
   adr = adr + 2;
  // index in RTTI array
   str_len = ReMakeWord(adr);
   setComment(adr, "Type: " + getRTTIName(Dword(rtti_base + str_len*4)), 1 );
   adr = adr + 2;
  // pascal string - name of component
   str_len = ReMakeByte(adr);
   adr = adr + 1;
   ReMakeStr(adr,str_len);
   adr = adr + str_len;
 }
  return rtti_base;
}

// process events handlers list
static processHandlers(adr,class_name)
{
 auto count, str_len;

 count = ReMakeWord(adr);
 setComment(adr,"Handlers count", 1);
 adr = adr + 2;
 for ( ; count; count-- )
 {
 // unknown dword
  ReMakeWord(adr);
  adr = adr + 2;
 // offset to function - handler
  MakeNameFOffset(adr, class_name + "." + getPStr(adr+4) );
  adr = adr + 4;
 // Name of handler
  adr = adr + makePStr(adr);
 }
}

// returns name of type published property
static get_type_name(adr)
{
 auto deref;

 deref = Dword(adr);
 if ( deref )
  return getPStr(deref + 1);
 else
  return "";
}

#define encodeKind(c, name)	if ( Ord == c ) return name;

static TypeOrdComm(Ord)
{
  encodeKind(otSByte, "signed byte" );
  encodeKind(otUByte, "unsigned byte" );
  encodeKind(otSWord, "signed word");
  encodeKind(otUWord, "unsigned word");
  encodeKind(otSLong, "signed long");

  return "";
}

static TypeOrdKind(Ord)
{
  encodeKind(tkUnknown, "unknown");
  encodeKind(tkInteger, "integer");
  encodeKind(tkChar, "char");
  encodeKind(tkEnumeration, "enum");
  encodeKind(tkFloat, "float");
  encodeKind(tkString, "string");
  encodeKind(tkSet, "set");
  encodeKind(tkClass, "class");
  encodeKind(tkMethod, "method");
  encodeKind(tkWChar, "WChar");
  encodeKind(tkLString, "LString");
  encodeKind(tkWString, "WString");
  encodeKind(tkVariant, "variant");
  encodeKind(tkArray, "array");
  encodeKind(tkRecord, "record");
  encodeKind(tkInterface,"interface");
  encodeKind(tkInt64,"int64");
  encodeKind(tkDynArray, "DynArray");

  return "";
}

static TypeOrdFloat(Ord)
{
  encodeKind(ftSingle, "single");
  encodeKind(ftDouble, "double");
  encodeKind(ftExtended, "extended");
  encodeKind(ftComp, "comp");
  encodeKind(ftCurr, "currency");
  return "";
}

#define encodeSet(c,name)	if ( (1<= vtbl_adr )
    {
      if ( ! vtbl_end )
        vtbl_end = my_name;
      else
       if ( vtbl_end > my_name )
         vtbl_end = my_name;
    }
  }
/* for debug only: Message("end of VTBL is " + ltoa(vtbl_end, 0x10) );   */
  for ( count = vtbl_end - vtbl_adr ; count > 0; count = count - 4 )
  {
    MakeFOffset(vtbl_adr);
    vtbl_adr = vtbl_adr + 4;
  }
 }
 if ( is_recursive && res)
  _processRTTI(res, is_recursive);
 return res;
}

// pre-check RTTI and ask about it
static askRTTI(adr)
{
 auto name, dyn_count, what_say;
 name = getRTTIName(adr);
 dyn_count = get_dyncount(adr);
 what_say = "Do you want to process RTTI of class \"" + name + "\"";
 if ( dyn_count )
  what_say = what_say + " with " + ltoa(dyn_count, 10) + " dynamic methods";
 what_say = what_say + "?";
 return AskYN(1, what_say);
}

// main function - process RTTI with small pre-checking
static processRTTI(adr)
{
 if ( 1 == askRTTI(adr) )
  _processRTTI(adr,0);
}

// process all RTTI from this (recursive)
static allRTTI(adr)
{
  if ( 1 == askRTTI(adr) )
    _processRTTI(adr,1);
}

static UnitEntries(adr)
{
  auto count, i;

  count = ReMakeInt(adr);
  adr = MakeOffset(adr + 4);
  if ( !adr || ! count )
    return;
  for ( i = 0; i < count; i++ )
  {
    MakeFOffset(adr);
    setComment(adr,ltoa(i+1,10) + " Initialize",1);
    adr = adr + 4;
    MakeFOffset(adr);
    setComment(adr,"Finalize",1);
    adr = adr + 4;
  }
}
Желаю удачи...

Den is Com [000859]