Советы по Delphi от Валентина Озерова

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


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

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

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

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

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

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

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

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

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

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


 Индексы

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

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

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

  1. [001178] Преобразование дробной и целой части REAL-числа в два целых
  2. [001193] Есть ли функция, выполняющая пpеобpазование пеpеменной real в integer?
  3. [001201] Почему непpавильно pаботает функция StrToFloat?
  4. [001530] Число строкой X
  5. [001804] Преобразование ICO в BMP III
  6. [001805] Преобразование иконок в Gliph'ы

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

  1. [001390] Добавление даты и времени в компонент Memo
  2. [001392] Вычисление даты Пасхи II
  3. [001394] Преобразование даты в количество секунд
  4. [001396] Преобразование даты в неделю
  5. [001397] Преобразование даты
  6. [001398] Преобразование даты - добавление столетия
  7. [001400] Приведение даты
  8. [001401] Даты и недели
  9. [001402] Количество дней между двумя датами I
  10. [001404] Количество дней между двумя датами II
  11. [001406] Конвертирование даты
  12. [001410] Число текущей недели
  13. [001413] Разница во времени
  14. [001415] Проблема со временем
  15. [001417] Переменная времени
  16. [001603] Алгоритм вычисления дня недели для Delphi1
  17. [001825] Как получить универсальные дату и время?

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

  1. [001832] Простой пример XOR шифрования

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

  1. [001146] Как научить Delphi делать правильное округление дробных чисел?

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

  1. [001058] Генерация еженедельных списков задач
  2. [001379] Генерация случайного пароля
  3. [001546] Проверка ISBN
  4. [001606] Есть ли у кого алгоритм переноса русского текста по слогам?

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

  1. [001471] Читаем Adobe Acrobat PDF файлы из нашего приложения

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

  1. [001301] Какие есть рекомендации по использованию Apollo SDE?

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

  1. [001498] Не работает передача данных по OLE в русский Excel

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

  1. [001561] Как мне работать с файлами MS Word или таблицами MS Excel?

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

  1. [001080] Как отследить открытие и закрытие документов в приложении Microsoft Word?
  2. [001147] Автоматизация WORD 7

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

  1. [001013] Передача переменных отчета в ReportSmith III

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

  1. [001313] Как правильно работать с SQLAnywhere через BDE -> ODBC -> SAW?

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

  1. [001063] Определение завершения работы Windows
  2. [001152] Как консольное приложение может узнать, что Винды завершаются?
  3. [001232] Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна?
  4. [001539] Постепенное умирание
  5. [001587] Как выполнить shutdown для удалённого компьютера?
  6. [001718] Как перегрузить Windows?

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

  1. [001084] Как раскрыть строки с подстановками вида '%SystemRoot%\IOSUBSYS\'?
  2. [001411] Изменение системного времени из Delphi II

[ API ][ Разное ]

  1. [001011] Как не допустить запуск второй копии программы VIII
  2. [001032] Как не допустить запуск второй копии программы IX
  3. [001170] Как не допустить запуск второй копии программы X
  4. [001425] Как не допустить запуск второй копии программы XI
  5. [001506] Как не допустить запуск второй копии программы XII
  6. [001836] Как не допустить запуск второй копии программы XIII
  7. [001136] Как правильно завершить некое приложение?
  8. [001140] Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
  9. [001163] Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp?
  10. [001168] Что нужно давать WSAAsyncSelect в качестве параметра handle, если тот запускается и используется в dll (init), и никакой формы (у которой можно было бы взять этот handle) в этой dll не создается?
  11. [001268] Вызов других программ
  12. [001412] Получение списка запущеных приложений
  13. [001518] Как мне запустить какую-нибудь программу? А как подождать, пока эта программа не отработает? Как выяснить, работает ли программа или уже завершилась? Как принудительно закрыть выполняющуюся программу?
  14. [001532] Открытие выбранного файла в работающем приложении
  15. [001536] Убиваем активное приложение
  16. [001549] Как перехватывать клавиши, нажатые в окне другой программы? И вообще, любые события, поступающие другим программам?
  17. [001608] Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?
  18. [001766] Изменение заголовка `чужого` окна
  19. [001777] Как запустить Windows Explorer, открытый на какой-то определенной папке?
  20. [001801] Работа с другим приложением без Hook и DLL на примере GetFocus
  21. [001820] Как создать мигающую иконку (свернутое окно)?
  22. [001830] Можно ли программно закрыть какое-либо приложение?
  23. [001835] Можно ли заблокировать обновление определенного окна?
  24. [001851] Как поменять приоритет моего приложения?
  25. [001855] Как можно гарантированно очистить экран в консольном приложении?

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

  1. [001013] Передача переменных отчета в ReportSmith III

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

  1. [001020] Получение пути псевдонима и таблицы I
  2. [001287] Получение пути псевдонима и таблицы II
  3. [001225] Получение пути псевдонима и таблицы III
  4. [001357] Получение пути псевдонима и таблицы IV
  5. [001209] Псевдоним на лету
  6. [001211] Псевдонимы
  7. [001217] Информация о псевдониме BDE
  8. [001225] Изменение каталога псевдонима во время выполнения приложения

[ BDE ][ Ошибки ]

  1. [001097] Ошибка BDE32 $2104
  2. [001219] Проблема BDE при использовании 'неживого' TQuery
  3. [001253] Делаем ApplyUpdates. Если пpи insert(update) пpоизошла ошибка (поле null, сpаботал check, etc.), то BDE всегда говоpит 'General SQL Error' вместо ноpмального сообщения об ошибке :-( Без CU все ноpмально, pазумеется. Как боpоть этот баг?
  4. [001271] Ошибка создания дескриптора курсора
  5. [001284] При разрушении обьектов, порожденных от TDataSet (TTable, TQuery), не отрабатывает событие OnBeforeClose. Что делать?
  6. [001290] При обращении к memo-полю из BDE возникает ошибка 'Memo too large'. Как лечить?
  7. [001291] Нарушение уникальности записи
  8. [001328] При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'. Как лечить?
  9. [001336] Как поймать свой RAISEERROR в Delphi?
  10. [001353] Как добиться верной работы фильтра на запросах и на неиндексированных таблицах?
  11. [001395] Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?
  12. [001429] Когда я применяю ApplyUpdates на ClientDataSet, на серверной стороне не срабатывает событие OnNewRecord для оригинального набора данных. Как это исправить?
  13. [001672] Перехват исключений базы данных

[ BDE ][ Oracle ]

  1. [001075] Связь Oracle с Win95
  2. [001238] Возникла необходимость в обработке исключительных ситуаций в PL/SQL процедуре (Oracle7 WG Server Release 7.3.2.2.0). Почему у меня не получается?
  3. [001274] Поясните, чем в Oracle являются понятия Instance, Database etc.?
  4. [001280] Как заставить Oracle анализировать все таблицы базы данных?
  5. [001282] В режиме отладки приложения не разрешается доступ (открытие) базы данных. Как лечить?
  6. [001349] Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?
  7. [001363] Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE?
  8. [001371] Как в Oracle создать sequence с некоторого номера?
  9. [001373] Как решать некоторые вопросы при подключении к Oracle?
  10. [001504] WindowsNT 4.0 + Delphi 2.01 C/S + Oracle Client 7.3 + Oracle Server 7.3. После логина в базу данных возникает `EExternalError 0xC0000008`. Что делать?
  11. [001571] Как правильно соединяться с базой данных под Personal Oracle?

[ BDE ][ InterBase ]

  1. [001065] FAQ по InterBase
  2. [001247] Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?
  3. [001249] Как скомпилиpовать UDF для Interbase под Linux RH 4.0?
  4. [001255] Как узнать текущие дату и время в Interbase?
  5. [001257] После снесения через родной uninstall Interbase Server 5.0 для Windows и желания поставить 5.1.1 вылетает ошибка: IBCheck. Что делать?
  6. [001326] При попытке регистрации UDF возникает ошибка (udf not defined). Что не так?
  7. [001391] Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию?

[ BDE ][ ODBC ]

  1. [001207] Добавление ODBC-драйверов в Delphi 3

[ BDE ][ SQL ]

  1. [001009] Функции дат в SQL
  2. [001022] Зарезервированные слова Local SQL
  3. [001048] Сиротские Master-записи
  4. [001216] Назначение SQL-счетчика переменной
  5. [001244] Как удобнее работать с динамически формируемыми запросами?
  6. [001275] Поиск записи в SQL DataSet
  7. [001286] При попытке выполнения такого оператора SQL - 'DELETE from T39 T39C0 WHERE T39C0.F1LHT35=253291661' SQL-сервер ругается на недопустимый синтаксис. В чем я неправ?
  8. [001346] Поиск с помощью SQL
  9. [001351] Как получить результирующим полем разницу между хранимой датой и текущей датой?
  10. [001354] SQL и поле даты
  11. [001356] SQL-запросы в Delphi
  12. [001358] SQL: - сортировка вычисляемого поля
  13. [001360] SQL: - суммирование вычисляемого поля
  14. [001362] SQL: - использование функции SUBSTRING

[ BDE ][ Sybase ]

  1. [001077] 32-битное соединение с сервером Sybase

[ BDE ][ Разное ]

  1. [001017] Решение проблемы BDE ~Index out of Date~
  2. [001029] Обратные вызовы BDE32 для получения статуса операций
  3. [001035] Управление сетевыми каталогами (BDE)
  4. [001054] Пример DBIDoRestructure
  5. [001055] Изменение конфигурации IDAPI
  6. [001064] Default Cursor после завершения выполнения запросов
  7. [001089] Протокол блокировки BDE
  8. [001236] Я так и не смог заставить выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки
  9. [001240] После analyze_schema некоторые (приличное количество) из запросов начинают сильно тормозить. Как лечить?
  10. [001241] БД-дерево взаимоотношений
  11. [001260] Определение установленной BDE
  12. [001289] Установка BDE
  13. [001307] Каковы текущие ограничения BDE?
  14. [001315] В процессе работы программы изменилась структура БД. Программа продолжала открывать таблицы, но запросы посылались в соответствии со старой схемой
  15. [001317] Как в Delphi сбросить кэш БД на диск?
  16. [001365] Как настроить MS SQL Server 6.5 на корректную работу с числами и BDE при выполнении UPDATE?
  17. [001367] Как научить VCL делать Refresh для запросов правильно?
  18. [001383] Как заставить BDE сохранять в БД поле времени с сотыми долями секунды?
  19. [001386] Запись буфера BDE на диск
  20. [001629] Я переписываю BDE-приложение на другой компьютер, а оно отказывается работать. Что делать?

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

  1. [001007] Хитрости многопользовательского доступа к БД
  2. [001012] Выполнение запросов к базе данных в фоне
  3. [001027] Получение физического пути к таблице
  4. [001221] Cancel в связанных таблицах
  5. [001264] Отображение формы ввода в БД CUSTOMER из рабочей формы ORDER
  6. [001265] Отображение определенных полей БД
  7. [001281] Из базы данных в переменные
  8. [001283] Получение информации о таблице
  9. [001295] Обмен данными между TMemoField и TMemo
  10. [001299] Если в транзакции изменена какая-то таблица, то для другого пользователя блокируется вся таблица, до окончания транзакции. Как лечить?
  11. [001300] Форма Мастер-Деталь
  12. [001303] Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?
  13. [001304] Как исключить показ поля P_RECNO?
  14. [001306] Информация из одной таблицы и набора данных на двух формах
  15. [001311] Как при вводе информации в БД автоматически вставлять SEQUENCE?
  16. [001325] Помещение переменной в Memo-поле
  17. [001327] Индикатор прогресса выполнения запроса
  18. [001337] Обновление данных БД из модальной формы
  19. [001359] Как записать в BLOB-поле большой текст (>255 байт) из Delphi?
  20. [001368] Блокировка таблицы
  21. [001384] Каким драйвером пользуется TDATABASE?
  22. [001387] Как создать новый запрос и скопировать туда точно такие же описания полей?
  23. [001388] Запись потока в BLOB-поле
  24. [001452] Как я могу выбрать на клиента только часть данных с определенной позиции из набора данных на сервере?
  25. [001456] Отследить изменение данных?
  26. [001469] Как достучаться до методов сервера приложений из TClientDataSet?
  27. [001473] Я включил dbclient.dll в секцию `additional files` опций распространения по web, но этот файл никогда не загружается на клиента. Как это исправить?
  28. [001480] Как можно использовать TClientDataSet в локальном приложении с таблицами Paradox, без использования компонент TProvider и TRemoteServer?
  29. [001502] Hе получается открыть таблицу, созданную в InterBase с DEFAULT CHARACTER SET WIN1251. Оно говорит, что `WIN1251 undefined`
  30. [001569] Почему при добавлении/изменении записей в некоторых запросах возникает ошибка Cannot modify a read-only dataset?

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

  1. [001227] Код определения возраста
  2. [001369] Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?
  3. [001385] Как создать вычисляемые поля во время исполнения программы (Calculated fields at RunTime)?

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

  1. [001006] Функции редактора полей во время выполнения программы
  2. [001015] Производная TIntegerField
  3. [001235] Создание новой таблицы на основе структуры другой таблицы
  4. [001254] Создание уникального ID для новой записи
  5. [001269] Динамическое создание таблицы и полей во время выполнения программы
  6. [001321] Проблема с AddIndex
  7. [001345] Как создать БД в кодировке CP1251?
  8. [001370] Таблицы в памяти

[ Базы данных ][ Модули данных ]

  1. [001014] Модуль данных для каждого MDIChild
  2. [001477] Как передать UserName и Password в удаленный модуль данных (remote datamodule)?

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

  1. [001332] Как заставить работать DB2 через протокол IPX?
  2. [001389] Почему DB2 ругается на Create Trigger?

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

  1. [001239] Текущий номер записи набора данных
  2. [001251] Как открыть индексированную таблицу dBase, если отсутствует файл индекса?
  3. [001258] Определение удаления записей в .DBF
  4. [001258] Определение номера записи в таблице dBASE
  5. [001308] Пакование таблиц dBASE II
  6. [001310] Пакование таблиц dBASE III
  7. [001355] Пакование таблиц dBASE IV
  8. [001312] Показ удаленных записей в таблице dBASE
  9. [001314] Пароль на dBASE-файлы
  10. [001333] Показ меток 'удаленных' записей в dBASE-файлах

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

  1. [001277] FindKey для нескольких полей
  2. [001296] Поиск существующей записи перед тем, как она будет вставлена
  3. [001382] Поиск фраз и записей переменной длины

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

  1. [001018] Byte-поля Paradox
  2. [001031] Доступ к таблицам Paradox на CD или c флагом только для чтения
  3. [001223] Нечувствительный к регистру поиск в первичном индексе Paradox
  4. [001233] Создание таблицы Paradox
  5. [001243] DBEdit и реальные значения
  6. [001263] Почему при создании таблицы Paradox с первичным нечувствительным к регистру индексом вываливается ошибка?
  7. [001292] Как сменить пароль (master password) для таблицы Paradox?
  8. [001322] Что нужно сделать для нормальной работы в одноранговой сети с базами Paradox?
  9. [001329] Переиндексирование файлов Paradox в пределах моей программы
  10. [001565] После работы программы не сохраняются изменения в базе Paradox
  11. [001567] Как мне упаковать Paradox или DBF таблицу?

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

  1. [001214] Помещение Memo-файла с ASCII-разделителем в Memo-поле таблицы
  2. [001234] Почему не всегда верно обновляются IndexDefs по Update?
  3. [001245] DBGrid и Memo-поля
  4. [001256] Убывающий индекс
  5. [001259] Как работать из Delphi напрямую с MS ADO (Microsoft Active Data Objects)?
  6. [001261] Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?
  7. [001267] Дублирование набора записей
  8. [001270] Как программно изменить LangDriver для таблиц dBase и Paradox?
  9. [001276] Существует ли средство для вывода определения структуры таблицы?
  10. [001278] У меня есть текстовые файлы, которые я хочу использовать в запросах к DB2, но не хочу создавать из них постоянные таблицы в базе. Что делать?
  11. [001293] Список структуры полей таблицы
  12. [001298] Создание индексного файла из Delphi
  13. [001318] Контекстное меню на основе базы данных
  14. [001323] Корректное закрытие базы данных приложением Delphi
  15. [001348] Изменение свойств базы данных во время выполнения приложения
  16. [001352] Как мне задать выражение по умолчанию для объекта TField?
  17. [001431] После того, как я использовал правый щелчок мыши для создания функции-провайдера, как мне снова выполнить команду контекстного меню `Export from Table`?
  18. [001465] Что я получаю от наличия ConstraintBroker (брокера ограничений)?
  19. [001482] Как работать с новыми, своими интерфейсами в RemoteDataModule?
  20. [001500] Database Desktop показывает содержимое таблиц шрифтом без русских букв
  21. [001633] SQL Explorer & Drag-n-Drop
  22. [001802] BLOBFIELD как BITMAP

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

  1. [001266] Открытие и закрытие нескольких приводов CD-ROM

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

  1. [001683] Как получить информацию о загрузке процессора?

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

  1. [001860] Как получить серийный номер тома жесткого диска?

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

  1. [001405] Переключение клавиатуры I
  2. [001616] Переключение клавиатуры II
  3. [001407] Как отловить нажатия клавиш в системе
  4. [001446] Клавиша с кодом #0
  5. [001545] Как из программы переключить раскладку клавиатуры?
  6. [001642] Каким образом можно спрятать приложение от показа при нажатии Alt+Tab?
  7. [001694] Подскажите пожалуйста как сделать имитацию ввода с клавиатуры для программы выполняющейся в дос-окне?
  8. [001704] Как включать/выключать лампочки на numlock, capslock, etc...?
  9. [001714] Тpебyется чтобы пpи нажатии =Enter= в любом из нескольких Edit-ов на фоpме, фокyс пеpеходил в следyющий
  10. [001753] Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC
  11. [001760] Включение/выключение клавиатуры
  12. [001770] Как убрать мою программу из списка Alt+Ctrl+Del?
  13. [001772] Перехват формой нажатия клавиши ESC
  14. [001816] Как определить нажатие PrintScreen?
  15. [001822] Как определить нажаты ли Shift, Control, Alt в определенный момент?
  16. [001834] Можно ли запретить Alt-F4, чтобы предотвратить закрытие формы?

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

  1. [001102] Как получить список установленных модемов в Win95/98?
  2. [001838] Как набрать номер модемом?
  3. [001839] Как использовать TAPI для набора телефона, чтобы поговорить голосом?

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

  1. [001745] Управление MouseOver через Hint
  2. [001764] Поменять кнопки мышки местами
  3. [001768] Изменение положения курсора мыши

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

  1. [001161] Ассинхронная связь

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

  1. [001059] Печать табуляторов с помощью TextOut
  2. [001072] Печать через спулер на матричный принтер
  3. [001081] Лучший способ печати формы
  4. [001114] Как мне отправить на принтер чистый поток данных?
  5. [001160] Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?
  6. [001821] Как вместо печати графикой сказать принтеру, чтобы печатал встроенными шрифтами?
  7. [001823] Как печатать в Дельфи без Tprinter?
  8. [001826] Как распечатать картинку?
  9. [001845] Как определить количество заданий на печать?

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

  1. [001597] Как умертвить PC Speaker?
  2. [001741] Звук через PC Speaker

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

  1. [001036] Как в ATX корпусе программно выключить питание под DOS
  2. [001743] Как в Delphi определить дату BIOS
  3. [001798] Как заблокировать ввод?

[ DLL ][ C++ ]

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

[ DLL ][ Ошибки ]

  1. [001654] Проблема использования в DLL чисел с плавающей точкой

[ DLL ][ Разное ]

  1. [001033] Синхронизация DLL с открытым набором данных
  2. [001086] Как вызывать функцию 16-битной DLL из 32-битного приложения?
  3. [001166] Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
  4. [001643] 16-битные DLL и Delphi 2
  5. [001645] Простой шаблон для Delphi DLL
  6. [001647] Пример обратного вызова DLL II
  7. [001650] Cards.DLL
  8. [001652] DLL: убийственная утилита
  9. [001655] Импортирование, или 'обертка' вызовов функций DLL
  10. [001657] Uses в DLL
  11. [001658] Функции VER.DLL
  12. [001677] Как работать с плагинами?
  13. [001843] Можно ли определить полный путь и имя файла запущенной DLL из самой DLL?

[ Интернет ][ Форматы ]

  1. [001078] UUE кодирование

[ Интернет ][ ISAPI ]

  1. [001448] Почему мои ISAPI-ориентированные библиотеки, созданные в Delphi 3, не могут обрабатывать несколько соединений?

[ Интернет ][ Соединение ]

  1. [001377] Проверка URL
  2. [001739] Dialer
  3. [001856] Как можно определить, что компьютер подключен к Интернету?

[ Интернет ][ Разное ]

  1. [001071] Объект DocInput
  2. [001073] Объект DocOutput
  3. [001381] Захват текущего URL у MSIE

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

  1. [001840] Как получить серийный номер AudioCD?

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

  1. [001026] Заставьте приложение Delphi 2 `петь`
  2. [001087] Создание нового WAV-файла
  3. [001088] Как реализовать регулятор громкости?
  4. [001096] Как использовать в своей программе API DirectSound и DirectSound3D?

[ OLE+ ][ ActiveX ]

  1. [001139] Ошибка 'EOLESYS..OPERATION UNAVAILABLE' (операция недоступна) при использовании GETACTIVEOLEOBJECT
  2. [001141] Ошибка 'TACTIVEFORMX DECLARATION MISSING OR INCORRECT' (определение TACTIVEFORMX отсутствует или неправильно)
  3. [001143] Лицензирование активных форм и ActiveX
  4. [001145] Добавление IPERSISTPROPERTYBAG к активным элементам управления
  5. [001149] Использование ChartFX
  6. [001151] CHARTFX - минимум максимум
  7. [001153] Пример CHARTFX
  8. [001155] Управление свойством Font через сервер автоматизации
  9. [001157] Использование CHARTFX.VBX
  10. [001159] VBX в приложениях DELPHI: как распространять?
  11. [001210] Расскажите, как использовать ChartFX?
  12. [001435] Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch?

[ OLE+ ][ DCOM ]

  1. [001454] В чем разница между сокетами, DCOM и OLE Enterprise при использовании их в качестве транспорта?

[ OLE+ ][ DDE ]

  1. [001419] DDE - передача текста
  2. [001421] Управление Program Manager в Win95 с помощью DDE
  3. [001423] GROUPFILE и ADDITEM для групп
  4. [001424] Как можно работать с DDE под Delphi, используя вызовы API?
  5. [001426] Как добавить группу в Program Manager?

[ OLE+ ][ OLE ]

  1. [001428] OLE-автоматизация в Delphi 1
  2. [001430] OLE сервер
  3. [001433] Как я могу избавиться от 'зарегистрированного' имени сервера, если я не хочу использовать его далее?

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

  1. [001122] Как удобнее работать с буфером обмена как с последовательностью байт?
  2. [001806] Помещение изображения в буфер обмена II

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

  1. [001074] Как програмным путем задавать координаты ярлыкам на рабочем столе?
  2. [001127] Как я могу использовать анимированный курсор?
  3. [001187] Как узнать текущее разрешение экрана?
  4. [001375] Как изменить изображение кнопки `Пуск`
  5. [001409] Как программно заменить обои на рабочем столе? III
  6. [001543] Как программно заменить обои на рабочем столе? IV
  7. [001510] А как поместить свою иконку на taskbar, там где часы и переключатель клавиатуры?
  8. [001526] Как ограничить перемещение курсора мыши какой-либо областью экрана?
  9. [001556] Как узнать и поменять разрешение экрана?
  10. [001585] Как запустить или закрыть скринсэйвер?
  11. [001669] Как пpогpаммно вывести окно свойств экpана?
  12. [001681] Как поместить иконку в Tray?
  13. [001722] Пpоцедуpу котоpая убиpает или показывает кнопку "Стаpт" в выне...
  14. [001786] Как добавить документы в папку `Старт`->`Документы`?
  15. [001829] Как отключить хранитель экрана?
  16. [001833] Как включить/отключить кнопку 'Старт'?
  17. [001837] Иногда, мое приложение, работающее в трее, не убирает всплывающее меню после потери фокуса. Чем помочь?
  18. [001841] Как очистить папку 'Документы' меню 'Старт'?

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

  1. [001085] Использование InputBox и InputQuery
  2. [001121] Текст на кнопках MessageDlg
  3. [001474] Изменения в TOpenDialog
  4. [001514] Как вывести диалог выбора каталога?
  5. [001671] Как вывести окно свойств компьютеpа?
  6. [001738] Заголовок диалогового окна
  7. [001740] Диалоги, модальные для всей системы
  8. [001776] Процедура обертки диалогового окна объектом
  9. [001844] Как запустить диалог поиска файла?
  10. [001848] Как показать стандартное окно копирования файлов?

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

  1. [001082] Как получить список файлов, которые были перенесены на мою форму, например, из Проводника?
  2. [001709] Как пpинимать яpлыки пpи пеpетягивании их на контpол?

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

  1. [001117] Хранение стилей шрифта
  2. [001487] Управление настройками шрифта
  3. [001595] Каким обpазом выбиpать pазмеp шpифта?
  4. [001744] Различные разрешения - различные размеры шрифтов

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

  1. [001034] Восстанавление длинных имен файлов по известным коротким
  2. [001056] Метка диска под Win32
  3. [001106] Как указать системе на необходимость сбросить буфера *.INI-файла на диск?
  4. [001124] Копирование файлов III
  5. [001403] Копирование файлов IV
  6. [001183] Как получить имя папки pабочего стола (не чеpез registry)?
  7. [001372] Количество строк в текстовом файле
  8. [001640] Как в Delphi определить, где установлена Windows?
  9. [001675] Слияние двух бинарных файлов
  10. [001678] Функция/процедура CopyFile
  11. [001679] Конец файла
  12. [001680] Файл типа TList
  13. [001682] Вопросы разделяемого доступа к файлу
  14. [001684] Разбиение и сборка файла
  15. [001686] Исправление ошибки записи на файл полей с данными
  16. [001688] Получение размера файла
  17. [001690] Переименование каталога
  18. [001691] Импорт больших файлов с разделителями
  19. [001693] Итерация подкаталогов
  20. [001695] Открытие файла только на чтение
  21. [001697] Чтение данных из файла
  22. [001698] Чтение и запись данных в/из файлов
  23. [001699] Чтение и запись файлов
  24. [001701] Чтение бинарного файла
  25. [001703] Чтение из файла длинной строки
  26. [001705] Рекурсивное удаление файлов и подкаталогов
  27. [001707] Сохранение в файле пятисот символов из массива
  28. [001710] Установка времени и даты файла
  29. [001712] Установка времени компиляции программы в диалоговом окне "О программе"
  30. [001713] Медленное копирование с диска на дискетту и обратно
  31. [001721] Запись и чтение из файла массива записей
  32. [001779] Как удалить директорию со всеми файлами в ней находящимися?
  33. [001831] Как отформатировать носитель под Win32?
  34. [001853] Как сбросить на диск кэшированную информацию о бинарном файле?

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

  1. [001133] Как послать самостийное сообщение всем главным окнам в Windows?
  2. [001414] Как избавиться от торможения модальных окон?
  3. [001516] Моя программа довольно долго делает какую-то полезную работу, типа чтения дерева каталогов или обильных вычислений, и в этот момент почти не работают остальные программы. Как разрешить им это делать?
  4. [001687] Как послать некое сообщение всем формам?
  5. [001847] Как сообщить какую-то глобальную переменную все (в т.ч. скрытым) окнам программы?

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

  1. [001120] Как узнать доступные сетевые pесуpсы?
  2. [001578] Как узнать кто висит на моей (или не моей) машине
  3. [001580] Как создать юзера и дать ему права?
  4. [001583] Как узнать ip адрес(а) машины (в текстовом виде)?
  5. [001589] Как подключать сетевые диски?
  6. [001601] Как по IP адресу получить HostName (и обратно)
  7. [001626] Как работать с поименованными каналами под W'95/NT в сети?

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

  1. [001673] Как очистить коpзинy?

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

  1. [001218] Как из программы выявить версию Windows, на кого зарегистрирована и т.п.?
  2. [001788] Как получить имя программы, с которой ассоциировано то или иное расширение?
  3. [001814] Удобная загрузка местоположения формы
  4. [001828] После того, как я внесу изменения в реестр, некоторые программы не видят их до перезагрузки, что можно сделать?
  5. [001850] Как сделать так, чтобы приложение загружалось при каждой загрузке Windows?
  6. [001858] Как узнать, откуда инсталлировалась Windows?

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

  1. [001272] Создание ярлыков I
  2. [001599] Создание ярлыков II
  3. [001653] Создание ярлыков III
  4. [001790] Как можно запустить *.lnk?

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

  1. [001735] Вызов процедуры в другом потоке

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

  1. [001001] `Устойчивые` всплывающие подсказки
  2. [001068] Вызов 16-разрядного кода из 32-разрядного
  3. [001094] Как проверить, имеем ли мы административные привилегии в системе?
  4. [001104] Как узнать язык Windows по умолчанию?
  5. [001197] GetLocalUserList - возвращает список пользователей (Windows NT, Windows 2000)
  6. [001212] Каков способ обмена информацией между приложениями Win32 - Win16?
  7. [001309] Остановка и запуск сервисов
  8. [001461] Прямой вызов метода Hint
  9. [001524] Как использовать свои курсоры в программе? I
  10. [001537] Как использовать свои курсоры в программе? II
  11. [001622] Как изменить внешний вид хинтов (всплывающих подсказок)?
  12. [001663] Как определить из под какой операционной системы запущена программа?
  13. [001667] Как заставить появляться хинт, когда я захочy?
  14. [001696] Как из своего пpиложения опpеделить загpузку pесуpсов GDI и USER?
  15. [001711] Как получить список процессов?
  16. [001724] Как повесить винду?
  17. [001732] Фyнкция опpеделения Win2K?
  18. [001765] Проблема всплывающих подсказок в дочерних MDI-формах
  19. [001784] Как получить список доступных носителей?
  20. [001792] Функция определения версии ОС
  21. [001849] Можно ли сменить шрифт всплывающих подсказок?

[ Pascal ][ Массивы ]

  1. [001043] Динамические массивы V
  2. [001180] Динамические массивы VI
  3. [001200] Динамические массивы VII
  4. [001416] Динамические массивы VIII
  5. [001171] Пример массива констант (Array of Const) III
  6. [001173] Массив объектов-изображений
  7. [001175] Массив TPOINT
  8. [001182] Создание больших массивов

[ Pascal ][ События ]

  1. [001460] Назначение обработчика события OnClick пункту меню, созданному во время выполнения программы
  2. [001513] События для компонентов, созданных во время работы программы I
  3. [001515] События для компонентов, созданных во время работы программы II
  4. [001570] Процедура OnClose
  5. [001573] Проблема горячих клавиш и OnKeyDown
  6. [001590] Назначения обработчика события во время выполнения программы
  7. [001627] Перехват OnEnter в моем компоненте
  8. [001789] Перехват событий дочерних MDI-форм

[ Pascal ][ Память ]

  1. [001119] Функция MemAvail для Delphi2?
  2. [001222] Как работать с блоками памяти размером более 64K?

[ Pascal ][ Объекты ]

  1. [001135] Проблема циклических ссылок
  2. [001184] Создание множества экземпляров

[ Pascal ][ Параметры ]

  1. [001196] Передача функции как параметра
  2. [001198] Проблема передачи записи

[ Pascal ][ Указатели ]

  1. [001190] Указатель на функцию I
  2. [001199] Указатель на функцию II
  3. [001205] Использование указателей на целое

[ Pascal ][ Свойства ]

  1. [001040] Хитрость вызова редактора свойств
  2. [001042] Редактор свойств для точки
  3. [001118] Как убрать публичное свойство компонента/формы из списка видимых/редактируемых свойств в Инспекторе Обьектов?
  4. [001489] Копирование свойств компонента
  5. [001519] Свойство FileName в невизуальном компоненте
  6. [001568] Имя свойства в течение выполнения программы
  7. [001575] Публикование свойств-наборов
  8. [001617] Проверка на существование свойства
  9. [001685] Как определить есть ли некоторое свойство (например, Hint) у объекта?

[ Pascal ][ Записи ]

  1. [001041] Пример переменной записи
  2. [001091] Передача массива записей символов в Memo
  3. [001203] Освобождение записей
  4. [001674] Файл с множеством записей

[ Pascal ][ Строки ]

  1. [001016] StrTok для Delphi 2
  2. [001512] Как мне перекодировать строки из Win-кодировки в Dos-кодировку и наоборот?

[ Pascal ][ Типы ]

  1. [001158] У меня константы могут иметь значение, отличное от заданного. Как лечить?
  2. [001169] Значение вычисляемого поля Paradox вместо 25.55 становится 24.5499999...
  3. [001176] Классовые/статические/переменные общего доступа
  4. [001181] Чем отличается тип String в Delphi 2 и выше от аналогичного в Delphi 1?
  5. [001186] Различия TMEMOFIELD
  6. [001192] Функция, возвращающая тип
  7. [001194] Преобразование формата MS BINARY в IEEE
  8. [001551] Почему у меня record a : word; b : longint end; имеет размер восемь байт вместо шести?
  9. [001593] Как корректно сравнивать и выполнять арифметические действия с четырехбайтными беззнаковыми целыми числами (DWORD)?
  10. [001706] С каким числовым форматом Delphi работает быстрее всего?
  11. [001715] Хранение TColor
  12. [001807] Сравнение чисел с плавающей точкой
  13. [001854] Как показать число, разделив каждые три цифры запятыми?

[ Pascal ][ Переменные ]

  1. [001202] Статические переменные

[ Pascal ][ Разное ]

  1. [001044] Переключение ключей компилятора
  2. [001123] Получение ссылки на класс из объекта I
  3. [001125] Получение ссылки на класс из объекта II
  4. [001436] Работа с комментариями в большом куске кода

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

  1. [001062] Кнопка с несколькими строчками текста III
  2. [001639] Какая кнопка Sender?

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

  1. [001331] Пересборка индексов с помощью TBatchMove
  2. [001393] Есть некоторая таблица и требуется при нажатии на кнопку создавать таблицы такой же структуры. Подскажите, как это удобнее всего сделать?

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

  1. [001324] Цветная кнопка
  2. [001523] Обработка щелчка нескольких кнопок, используя их заголовок

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

  1. [001476] Массив из CheckBox - использование разделяемого обработчика события I
  2. [001478] Массив из CheckBox - использование разделяемого обработчика события II
  3. [001509] Идентификация CheckBox'ов

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

  1. [001112] Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?
  2. [001481] Программное открытие ComboBox II
  3. [001483] Проблемы с ComboBox
  4. [001758] Hint в выпадающем списке ComboBox

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

  1. [001021] Исправление DBEdit MaxLength
  2. [001046] Поиск и управление TEdit/TField
  3. [001049] Insert/Override с помощью DBEdit
  4. [001533] Как очистить DBEdit

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

  1. [001010] Dbgrid и множественный выбор
  2. [001019] Вертикальная полоса прокрутки Dbgrid
  3. [001023] TDBGrid Lookup-поле в D2
  4. [001098] Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
  5. [001138] Dbgrid с цветными ячейками IV
  6. [001470] Dbgrid с цветными ячейками V
  7. [001501] Dbgrid с цветными ячейками VI
  8. [001167] Улучшенный Dbgrid
  9. [001213] Пример Drag and Drop между двумя Dbgrid
  10. [001242] Как заставить DBGrid сортировать данные по щелчку на заголовке столбца?
  11. [001246] DBGrid и TQuery
  12. [001248] DBGrid как навигатор
  13. [001250] Позиция DBGrid
  14. [001252] DBGrid - переход к следующей записи
  15. [001273] onClick и DBGrid
  16. [001279] Числа с плавающей точкой в DBGrid
  17. [001285] Получение данных DBGrid прежде, чем они будут отправлены: как мне узнать, что пользователь вводит в DBGrid?
  18. [001288] Хочу шапку в TDBGrid. Как сделать?
  19. [001302] Несколько таблиц в одном TDBGrid
  20. [001320] Как сделать так, чтобы в DBGrid напротив некоторых строк можно было бы галочку поставить?
  21. [001334] Как в TDBGrid pазpешить только опеpации UPDATE записей и запpетить INSERT/DELETE?
  22. [001335] Обновление TDBGrid после редактирования отдельной записи на отдельной форме
  23. [001339] Пересортица в коде полей TDBGrid во время вополнения программы
  24. [001340] В Delphi 3 и выше ползунок TDBGrid иногда может находится не только в трех фиксированных позициях. Что для этого нужно?
  25. [001341] Изменение месторасположение колонок в TDBGrid
  26. [001342] Решение проблемы передачи фокуса TDBGrid
  27. [001364] Как отучить TDBGrid от автодобавления новой записи?
  28. [001378] Две таблицы в одном TDBGrid
  29. [001455] Добавление к TDBGrid события OnClick
  30. [001464] Позиция ячейки в TDBGrid
  31. [001505] Показ Memo-поля в Dbgrid
  32. [001528] Как определить изменение фокуса строки в TDBGrid?
  33. [001540] Включение ComboBox в TDBGrid
  34. [001613] TDBGrid и вертикальная полоса прокрутки I
  35. [001638] TDBGrid и вертикальная полоса прокрутки II

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

  1. [001319] Предустановка DBLookupComboBox
  2. [001350] Сортировка DBLookupComboBox по вторичному индексу
  3. [001380] Значение DBLookupComboBox
  4. [001632] Две колонки в DBLookupComboBox

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

  1. [001231] Копирование содержимого DBMemo в DBMemo другого поля
  2. [001344] Поиск текста в DBMemo

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

  1. [001008] Настройки всплывающих подсказок в DBNavigator во время выполнения приложения
  2. [001165] Выключение кнопок в DBNavigator
  3. [001229] Работа в коде с кнопками DBNavigator

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

  1. [001664] Drag and Drop: как использовать ITEMATPOS для получения элемента DIRLISTBOX?

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

  1. [001164] Денежное поле редактирования
  2. [001541] Отслеживаем позицию курсора в EditBox
  3. [001555] Числовая маска компонента Edit c помощью OnKeyPress III
  4. [001581] Правое выравнивание текста в компоненте Edit
  5. [001615] TEdit и событие OnEnter
  6. [001716] Как получить позицию курсора в TEdit?

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

  1. [001126] Рисование на GroupBox
  2. [001447] Доступ к компонентам GroupBox

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

  1. [001126] Рисование на GroupBox
  2. [001534] Как сделать бегущую стpоку?
  3. [001588] SendMessage и TLabel

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

  1. [001025] Навигация в ListBox при множественном выборе
  2. [001038] Внешние данные и ListBox
  3. [001115] Инкрементальный поиск в ListBox II
  4. [001445] Табуляция в графическом ListBox'е
  5. [001458] Выравнивание в ListBox'е
  6. [001492] Создание ListBox во время выполнения программы
  7. [001507] Двойной ListBox
  8. [001547] ListBox - OnChange
  9. [001548] ListBox с графикой
  10. [001566] Имя элемента ListBox
  11. [001602] Хранение переменных в ListBox
  12. [001610] Как добавить горизонтальную полосу прокрутки в TListBox?

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

  1. [001154] Как рисовать картинки в пунктах меню (через OwnerDraw)?
  2. [001579] Элементы меню с правым выравниванием
  3. [001623] TMenuItem - создание и добавление событий во время работы приложения
  4. [001637] Исправление иконок выключенных пунктов меню
  5. [001769] Действие меню для нескольких форм

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

  1. [001852] Как проиграть AVI на полный экран?

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

  1. [001449] Получение данных из компонента Memo
  2. [001468] Изменение поведения Delete в компоненте Memo
  3. [001544] Вставка текста в TMemo II
  4. [001562] Перемещение по Memo

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

  1. [001529] Включение/Выключение закладки Notebook II
  2. [001552] Основные различия между TABSET у NOTEBOOK и TABBEDNOTEBOOK

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

  1. [001517] Раскрытие пути к элементу TOutline по его индексу
  2. [001659] TOutline: Перетащи и брось I
  3. [001661] TOutline: Перетащи и брось II
  4. [001661] TOutline: Перетащи и брось III
  5. [001719] TOutline: чтение из файла

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

  1. [001024] Динамические PageControl/TabSheet I
  2. [001028] Клавиши-акселераторы для TPageControl
  3. [001531] Динамические PageControl/TabSheet II

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

  1. [001490] Создание панелей во время работы приложения

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

  1. [001503] Вызов контекстного меню в позиции курсора II
  2. [001574] Вызов контекстного меню в позиции курсора III
  3. [001538] Иконки в PopupMenu
  4. [001700] Вызов контекстного меню в координатах курсора мыши

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

  1. [001294] ProgressBar с невидимой рамкой

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

  1. [001343] Можно ли использовать результаты выполнения одного TQuery для другого TQuery?
  2. [001361] Можно ли вызвать хранимую процедуру через TQuery, если она не возвращает курсора?
  3. [001374] TQUERY и TDBGRID
  4. [001376] Две и более команд в свойстве TQUERY.SQL

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

  1. [001004] Группа радиокнопок и ActiveControl

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

  1. [001142] Как вставить в нужное место Rich Text в TRichEdit?
  2. [001144] Как указать максимальный размер текста для TRichEdit?
  3. [001495] Позиция курсора в TRichEdit
  4. [001586] Прокрутка TRichEdit
  5. [001631] Об модернизации объекта Richedit
  6. [001660] Печать из RichEdit

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

  1. [001128] Мерцание ScrollBar
  2. [001817] Как отловить сообщения о прокрутке TscrollBar?

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

  1. [001662] Drag and Drop из TScrollBox

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

  1. [001134] Speedbutton и Glyph

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

  1. [001598] Splitter Bar

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

  1. [001600] Показ даты/времени/состояния клавиш в строке состояния
  2. [001624] Как вставить в StatusPanel свои компоненты, например ProgressBar? I
  3. [001625] Как вставить в StatusPanel свои компоненты, например ProgressBar? II

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

  1. [001045] Обновление картинки в ячейке StringGrid
  2. [001050] Многострочность в заголовках колонок StringGrid
  3. [001107] StringGrid без выделенной ячейки
  4. [001109] Один щелчок на StringGrid вместо трех
  5. [001366] StringGrid как DBGrid
  6. [001444] `Авторазмер` для StringGrid
  7. [001457] Выравнивание колонок StringGrid III
  8. [001466] Выравнивание колонок StringGrid IV
  9. [001796] Выравнивание колонок StringGrid V
  10. [001479] Покрашенный StringGrid I
  11. [001499] Покрашенный StringGrid II
  12. [001511] Редактирование в StringGrid
  13. [001550] Сбрасывается HighLight-цвет выбранной ячейки в StringGrid
  14. [001553] Tab как Enter в StringGrid
  15. [001557] Поиск по маске в StringGrid
  16. [001558] Потеря визуального курсора в StringGrid
  17. [001560] Многострочный TStringGrid
  18. [001564] Множественный выбор в TStringGrid
  19. [001572] Событие OnDraw для TStringGrid
  20. [001577] Ограничение длины поля TStringGrid
  21. [001582] Правое выравнивание текста в TEdit и колонок в TStringGrid
  22. [001584] Размер экрана и TStringGrid
  23. [001592] SetFocus в TStringGrid
  24. [001604] Форматирование ячеек TStringGrid
  25. [001605] Правое выравнивание ячеек TStringGrid
  26. [001641] Манипуляция словами в TStringGrid

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

  1. [001069] Tabbednotebook и куча ресурсов
  2. [001451] Доступ к страницам Tabbednotebook
  3. [001596] Разделяемые элементы управления для Tabbednotebook I
  4. [001609] Разделяемые элементы управления для Tabbednotebook II
  5. [001611] Разделяемые элементы управления для Tabbednotebook III

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

  1. [001030] Над какой закладкой курсор?

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

  1. [001237] Создание таблицы в модуле

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

  1. [001472] Изменение количества закладок в TTabSet во время выполнения программы
  2. [001607] Синхронизация TabSet c ListBox

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

  1. [001408] Остановка таймера на `полпути`
  2. [001628] Некоторые вопросы про таймер
  3. [001794] Как можно обойтись без Ttimer и наиболее рационально использовать ресурсы системы?

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

  1. [001692] TrackBar для эстетов

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

  1. [001005] Поточность TreeView
  2. [001039] Получение доступа к узлам TreeView
  3. [001191] Хочется выделять некотоpые стpочки в TTreeView жиpным или бледным. Как?
  4. [001612] Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?
  5. [001620] Как убрать всплывающие подсказки в TreeView?
  6. [001630] Ускорение работы TreeView II
  7. [001708] Сохранение содержимого TreeView
  8. [001747] Как сделать так, чтобы в TreeView текущий Node выделялся другим шрифтом, типа Underline и т.д.?

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

  1. [001330] Что нужно знать о принципе и порядке работы с TUpdateSQL для работы с неживыми запросами?

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

  1. [001720] Как у TWebBrowser (IE4 ActiveX) показать диалог Find?

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

  1. [001083] Создание компонентов для работы с базами данных
  2. [001162] Динамическое создание компонент во время работы приложения
  3. [001188] Решение для динамически создаваемых компонентов
  4. [001189] Как правильно создавать органы управления в runtime?
  5. [001224] Как создать клон (копию, достаточно близкую к оригиналу) произвольного компонента?
  6. [001338] Как заставить произвольный компонент реагировать на изменения в TDataSource?
  7. [001453] Доступ к другим компонентам из базового
  8. [001463] CANVAS.TEXTWIDTH
  9. [001485] Создание компонента
  10. [001497] Циклический опрос компонентов
  11. [001522] Мне надо добавить много строк в TListbox или в TCombobox или в TMemo или в TRichEdit, при этом сам объект постоянно мигает, перерисовываясь. Как избавиться от этого?
  12. [001525] Как мне создать компонент типа TField?
  13. [001542] Инкрементация строкового поля
  14. [001559] Как правильно создавать компоненты в run-time? Что задавать в качестве параметра Owner при создании компоненты? Как обрабатывать события от созданных компонент, типа нажатий на кнопки?
  15. [001594] Установка границ для вновь создаваемых элементов управления
  16. [001634] Использование холста в собственных компонентах
  17. [001636] Управление именами переменных
  18. [001730] Компонента HTML - редактора
  19. [001795] Максимальное количество компонентов в .DCR
  20. [001812] Как бы попроще перемещать компонент во время работы программы?

[ Классы ][ TApplication ]

  1. [001563] Как сделать так, чтобы запущенная программа не была видна на панели задач?
  2. [001727] Закрытие приложения при его деактивации
  3. [001763] Как заставить приложение запускаться в минимизированном состоянии?

[ Классы ][ TForm ]

  1. [001002] fsStayOnTop ~не наверху~
  2. [001037] Без иконки в панели задач?
  3. [001052] Передача переменных форме
  4. [001053] Освобождение экземпляров формы
  5. [001057] Условие создания главной формы?
  6. [001067] Динамическое создание и циклическое связывание форм
  7. [001070] Как заставить формы минимизироваться на панель задач с анимацией?
  8. [001076] Перемещение формы не за заголовок III
  9. [001113] Перемещение формы не за заголовок IV
  10. [001090] Как работать с формой, куда динамически передаются страницы (PageControl) из форм-хранителей (с использованием наследования)?
  11. [001092] IMHO файл *.dfm - это компилированный ресурс с определением установок формы. А можно ли как-то увидеть этот ресуpс в исходном виде?
  12. [001105] Определение перемещения формы
  13. [001751] Определение перемещения формы II
  14. [001110] Можно ли сделать так - одновременно иметь на экране всегда доступную форму - например, 'Hавигатор', и, открывая модальные формы, иметь всегда доступ к форме 'Hавигатор'?
  15. [001116] Как создать окна непрямоугольной формы и работать с ними?
  16. [001131] Как запретить кнопку Close [x] в заголовке окна?
  17. [001132] Мерцание формы
  18. [001148] Минимизация модального окна
  19. [001150] Прозрачная форма
  20. [001156] Каким образом можно изменить системное меню формы?
  21. [001179] Как сделать MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов?
  22. [001228] Заполнение изображением MDI-формы IV
  23. [001399] Предотвращение закрытия формы
  24. [001420] Немедленный TrayIcon после старта приложения
  25. [001422] Заполнение формы изображением
  26. [001427] Создание консольных приложений
  27. [001459] События приложения
  28. [001467] Нужны ли мне формы в сервере приложений?
  29. [001493] Создание формы на основе строки
  30. [001508] Показ логотипа при запуске приложения III
  31. [001527] Показ логотипа при запуске приложения IV
  32. [001520] Как правильно закрыть и удалить форму? Почему моя MDI Child форма при закрывании просто минимизируется?
  33. [001535] Как установить максимальный и минимальный размер формы
  34. [001591] Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?
  35. [001644] Как сделать невидимой главную форму?
  36. [001656] Модальные формы с нормальной минимизацией
  37. [001665] Как минимизиpовать все запущеные окна?
  38. [001723] Добавление к форме BorderIcons
  39. [001725] Вызов функций из различных дочерних MDI окон
  40. [001729] Закрытие модальной формы
  41. [001731] Управление максимизацией формы
  42. [001734] Создание формы с шириной < 102
  43. [001736] Разрушение модальной формы при деактивации
  44. [001737] Ограничение размеров окна
  45. [001742] Получение различных диалогов из шаблона формы
  46. [001746] Отключение ALT+F4
  47. [001748] Форма не существует? Так создайте!
  48. [001750] Перемещение формы не за заголовок V
  49. [001752] Максимальная ширина формы
  50. [001754] FORM.TFORM.CREATE(???)
  51. [001755] Масштабирование окна III
  52. [001756] Освобождение формы
  53. [001757] Получение имени формы
  54. [001759] Скрытие окна заголовка формы
  55. [001761] Предотвращение изменения размера формы
  56. [001762] Сколько открыто дочерних окон?
  57. [001767] Размеры MDI-окна
  58. [001771] Открытие MDI-окон определенного размера
  59. [001773] Как добавить свой пункт в системное меню программы?
  60. [001774] Позиционирование динамически создаваемой формы
  61. [001778] Помещение формы в поток
  62. [001780] Работа без форм
  63. [001781] Выбор дочерних MDI-окон с помощью набора закладок TabSet
  64. [001783] Установление фокуса при открытии модального окна
  65. [001785] Изменение размера дочерних MDI-окон
  66. [001787] Прозрачный логотип
  67. [001791] Альтернатива главной форме?
  68. [001813] Различные размеры окна на различных платформах...
  69. [001819] Можно ли рисовать на рамке окна?
  70. [001827] Как создать собственное hint-окно?
  71. [001842] Как создать новую форму, которая бы не отбирала фокус у существующей?
  72. [001846] Как запретить кнопки системного меню окна, `Закрыть`, `Открыть`?
  73. [001859] Можно ли реагировать на максимализацию/минимизацию окна до того, как это произойдет?

[ Классы ][ TIniFile ]

  1. [001130] Проблемы ini-файла
  2. [001418] Как создать Ini-файл в директории программы?

[ Классы ][ TMemoryStream ]

  1. [001717] TMemoryStream

[ Классы ][ TRegistry ]

  1. [001195] Дополненный TRegistry, умеет работать с значениями типа REG_MULTI_SZ (Windows NT, Windows 2000)
  2. [001475] Как я могу определить доступные сервера приложений на этой машине через Registry?

[ Классы ][ TStringList ]

  1. [001635] Использование TstringList в визуальных компонентах

[ Миграция ][ Delphi 2 ]

  1. [001111] Совместимость D1/D2

[ Миграция ][ Delphi 3 ]

  1. [001496] Куда из Delphi 3 делся модуль для работы с ReportSmith? А мои любимые модули работы с OLE: ole2, oleauto и olectl?

[ Ошибки ][ Delphi 1 ]

  1. [001003] Ошибка маски редактирования на быстрых пентиумах
  2. [001103] PASDBK16.DLL вызывает GPF
  3. [001439] Ошибка переполнения диска

[ Ошибки ][ Delphi 2 ]

  1. [001093] Ошибка чтения потока

[ Ошибки ][ Delphi 5 ]

  1. [001297] Ошибка в ProgressBar

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

  1. [001668] Обработка исключительных ситуаций
  2. [001670] Как обработать ошибку предже, чем программа уведомит об этом пользователя?
  3. [001797] Ошибки времени выполнения
  4. [001857] Как получить текстовое описание ошибки, полученной GetLastError?

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

  1. [001047] 256-цветное изображение из res-файла
  2. [001108] Как записать содержимое окна OpenGL в 'bmp' файл?
  3. [001129] Как создать disable'ный битмап из обычного (emboss etc)?
  4. [001137] Компонент для работы с FLIC-анимацией
  5. [001172] Как сделать, чтобы орган управления, например, сложная линия, хваталась только за некий контур, и пропускала мышь под себя в других местах?
  6. [001177] Как быстро нарисовать тень в заданном регионе?
  7. [001185] Как рисовать на органе управления, например, на TPanel?
  8. [001204] Как мне из Handle битовой картинки, получить адрес битового изображения в памяти?
  9. [001220] Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?
  10. [001230] Как вывести на экран текст с 'красивым' обрезанием по длине (если текст не помещается на экране)?
  11. [001494] При работе программ на Delphi 1 под Windows 95 в hicolor-режимах на иконках TBitBtn'ов обнаруживаются странные коричневые артефакты. Как от них избавиться?
  12. [001494] Получение контекста устройства для элемента управления
  13. [001576] TCanvas и освобождение дескрипторов
  14. [001614] Как вывести на Canvas надпись под углом?
  15. [001618] Как скопировать экран (или его часть) в TBitmap?
  16. [001619] Вертикальный текст
  17. [001621] Вывод текста на родительском элементе управления
  18. [001646] Как рисовать прямо на экране?
  19. [001651] Как быстро выводить графику? (А то Canvas очень медленно работает)
  20. [001702] Как бороться с "квадратичностью" Image
  21. [001733] Копирование содержимого экрана на форму
  22. [001775] Как можно узнать количество цветов текущего режима?
  23. [001799] Назначение палитры Bitmap
  24. [001800] Прозрачный Bitmap
  25. [001803] Вращение изображения II
  26. [001808] Delphi и графика
  27. [001809] Рисование графов
  28. [001810] Как поместить прозрачный текст на Canvas Tbitmap?
  29. [001811] Как быстро очистить канву?
  30. [001815] Получение DC элемента управления
  31. [001818] Как поменять цвет фона текста?

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

  1. [001101] Не могу открыть файл помощи...
  2. [001206] Как сделать так, чтобы в приложении вызывался хелп с окошечком для поиска раздела?
  3. [001208] Как заставить Help-файлы нормально отображать русский текст под Windows 3.x?

[ Разное ][ IDE ]

  1. [001060] Копирование проекта в новый каталог
  2. [001061] Использование Tools Interface
  3. [001066] Зависание Delphi 4(5)
  4. [001095] Ошибка 1157 cmplib32.dll
  5. [001432] 2% ресурсов, в режиме редактирования
  6. [001434] Активизация и использование в IDE окна CPU
  7. [001438] Описание типов файлов для Delphi
  8. [001442] Определение работы Delphi III
  9. [001443] Работа с IDE из программы
  10. [001486] Как исправить проблемы с вызовом помощи при одновременно стоящих Delphi 1 и Delphi 2?
  11. [001488] Delphi 2 и 3 не отображают русские TTF под Windows NT WorkStation + ServicePack#3
  12. [001782] Как поменять ширину и высоту IDE-редактора по-умолчанию?
  13. [001824] Как перевести *.dfm в *.txt и обратно?

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

  1. [001347] Борьба с SoftIce

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

  1. [001726] Как во время компиляции модуля определить, под какой версией Delphi она происходит?
  2. [001793] Связывание функций

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

  1. [001441] Hard mode без перерыва II
  2. [001491] При возникновении ошибки во время отладки программы машина перезагружается. Что делать?

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

  1. [001051] Пример ресурсной таблицы строк
  2. [001099] Компиляция ресурсов
  3. [001440] Ошибка дублирования идентификатора ресурса
  4. [001450] Сохранение и выдёргивание ресурсов в DLL или EXE
  5. [001554] Можно ли сделать так, чтобы в исполняемом файле программы находился какой-нибудь звук в формате .wav, и можно было бы проиграть этот звук?
  6. [001649] Есть программа на Delphi, котоpая отображает какой-то html. В html используется gif-файл. Как в Delphi-пpоекте указать, чтобы этот gif находился в exe как некий кусок кода. А когда надо будет, записать его обратно в gif-файл без изменений, выковырнув из exe?
  7. [001689] Как DLL правильно заполнить строковыми ресурсами, и потом достать их?

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

  1. [001079] Переустановка Delphi 2.0
  2. [001100] Как проводить локализацию своих приложений?
  3. [001215] crtdll.dll в программах на Delphi
  4. [001226] Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме (но не в модальных окнах, к примеру)?
  5. [001305] При использовании MS SQL Server 6.5 в NT Performance Monitor исчезли все датчики, кроме SQL
  6. [001462] xWindows - FAQ
  7. [001484] Каким именно релизом Delphi вообще стоит пользоваться для каждой конкретной версии?
  8. [001676] Код ASCII для EOF
  9. [001728] `Cамоубийство` программы
  10. [001749] Создаём собственный UnRar, используя unrar.dll


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

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

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

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

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

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

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

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

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

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

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

Помните

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

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


Цены

Услуга | Стоимость
Справочная система "Советы по Delphi" | Бесплатно
Размещение монопольного банера на титульной странице в течение месяца | На правах обмена
Прием советов | Бесплатно


Преобразование дробной и целой части REAL-числа в два целых

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

Для ее запуска достаточно в подсказке DOS набрать ее имя и число:

CONTFRAC 3.141592654
program contfrac;       { непрерывные дроби }
{$N+}
const
order    = 20;
var
y,
lasterr,
error,
x               : extended;

a               : array[0..order] of longint;
i,j,
n               : integer;
op,
p,
q               : longint;

begin
lasterr := 1e30;
val(paramstr(1), y, n);
if n <> 0 then
halt;
x := y;
a[0] := trunc(x);

writeln;
writeln(a[0]:20, a[0]:14, 1:14);

{ это может вызвать резкую головную боль и галлюцинации }

for i := 1 to order do begin
x := 1.0 / frac(x);
a[i] := trunc(x);
p := 1;
q := a[i];
for j := pred(i) downto 0 do begin
op := p;
p := q;
q := a[j] * q + op;
end;
error := abs(y - int(q) / int(p));
if abs(error) >= abs(lasterr) then
halt;
writeln(a[i]:20, q:14, p:14, error:10);
if error < 1e-18 then
halt;
lasterr := error;
end;
end.

Теперь попытаюсь объяснить мой алгоритм (он, по-моему, достаточно быстрый). Вот схема:

Допустим, мы используем число 23.56.

Берем наше натуральное число и производим целочисленное деление на 1.

23.56 div 1 = 23

Теперь вычитаем результат из числа, с которого мы начали.

23.56 - 23 = .56

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

             valA := (val div 100);
             valB := (valA - val); or valB := (valA - val) * 100;

                val = 23.56
                ValA = 23
                ValB = .56 or 56
[001178]


Есть ли функция, выполняющая пpеобpазование пеpеменной real в integer?

Nomadic советует:

Hа самом деле есть две функции - Round и Trunc (округление и отсечение дробной части соответственно).

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

Hy, если yж дело идет к изyчению списка фyнкций :), то yпомянy еще Ceil и Floor. Unit Math;

Кстати, втоpая из них мне очень пpигодилась для полyчения экспоненты числа. Имеется в видy экспонента: X=1E 13 [001193]


Почему непpавильно pаботает функция StrToFloat?

Nomadic советует:

Пишу даже прямо StrToFloat('32.34'), к примеру, получаю исключение "'32.34' is not valid float". Если пишу число без десятичной точки, то все ОК. А какой у тебя DecimalSeparator? В Russian settings почему-то по умолчанию считается, что разделитеь дроби - запятая. Пеpеустанови пpи запуске пpогpаммы

DecimalSeparator := '.';

Или пользуйся этой функцией так:

StrToFloat('32,24');

[001201]


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

Сергей AKA WildSery прислал свой вариант:

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

function currency2Str (value: double): string;

const hundreds: array [0..9] of string = ('',' сто',' двести',' триста',' четыреста',' пятьсот',' шестьсот',' семьсот',' восемьсот',' девятьсот');
tens: array [0..9] of string = ('','',' двадцать',' тридцать',' сорок',' пятьдесят',' шестьдесят',' семьдесят',' восемьдесят',' девяносто');
ones: array [0..19] of string = ('','','',' три',' четыре',' пять',' шесть',' семь',' восемь',' девять',' десять',' одиннадцать',' двенадцать',' тринадцать',' четырнадцать',' пятнадцать',' шестнадцать',' семнадцать',' восемнадцать',' девятнадцать');
razryad: array [0..6] of string = ('',' тысяч',' миллион',' миллиард',' триллион',' квадриллион',' квинтиллион');

var s: string; i: integer; val: int64;

function shortNum(s: string; raz: integer): string;
begin
Result:=hundreds[StrToInt(s[1])]; if StrToInt(s)=0 then Exit;
if s[2]<>'1' then begin
Result:=Result+tens[StrToInt(s[2])];
case StrToInt(s[3]) of
1: if raz=1 then Result:=Result+' одна' else Result:=Result+' один';
2: if raz=1 then Result:=Result+' две' else Result:=Result+' два';
else Result:=Result+ones[StrToInt(s[3])];
end;
Result:=Result+razryad[raz];
case StrToInt(s[3]) of
0,5,6,7,8,9: if raz>1 then Result:=Result+'ов';
1: if raz=1 then Result:=Result+'а';
2,3,4: if raz=1 then Result:=Result+'и' else if raz>1 then Result:=Result+'а';
end;
end else begin
Result:=Result+ones[StrToInt(Copy(s,2,2))];
Result:=Result+razryad[raz];
if raz>1 then Result:=Result+'ов';
end;
end;

begin
val:=Trunc(value);
if val=0 then begin Result:='ноль'; Exit; end;
s:=IntToStr(val); Result:=''; i:=0;
while Length(s)>0 do begin
Result:=shortNum(Copy('00'+s,Length('00'+s)-2,3),i)+Result;
if Length(s)>3 then s:=Copy(s,1,Length(s)-3) else s:='';
inc(i);
end;
s:=IntToStr(Trunc((value-val)*100+0.5));
Result:=Result+' руб. '+s+' коп.';
end;

[001530]


Delphi 1

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

procedure TIconShow.FileListBox1Click(Sender: TObject);
var
MyIcon: TIcon;
MyBitMap : TBitmap;
begin
MyIcon := TIcon.Create;
MyBitMap := TBitmap.Create;

try
{ получаем имя файла и связанную с ним иконку}
strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
StrPCopy(cStrFileName, strFileName);
MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);

{ рисуем иконку на bitmap в speedbutton }
SpeedButton1.Glyph := MyBitMap;
SpeedButton1.Glyph.Width := MyIcon.Width;
SpeedButton1.Glyph.Height := MyIcon.Height;
SpeedButton1.Glyph.Canvas.Draw(0,0, MyIcon);

SpeedButton1.Hint := strFileName;

finally
MyIcon.Free;
MyBitMap.Free;
end;
end;

[001804]


Delphi 1

Преобразование иконок в Gliph'ы

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

Огорчен, но комментарии в исходном коде на испанском языке.

unit Procs;

interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, StdCtrls, Buttons, ExtCtrls, ShellAPI;

procedure LlenaBoton(boton: TSpeedButton; Programa: string);
procedure LimpiaBoton(boton: TSpeedButton);

var
{Botones de programas}
Pic: TPicture;
Fname : String;
TempFile: array[0..255] of Char;
Icon : TIcon;

implementation
uses ttotro;

procedure LlenaBoton(boton: TSpeedButton; Programa: string);
var
NumFiles, NameLength : integer;
nIconsInFile : word;
rBoton : TRect;
oBitmap : TBitmap;
oBitmap2: TBitmap;
NombreBitmap: string;

begin

try
screen.cursor := crHourglass;

{Extrae el Icono}
Icon := TIcon.Create;
StrPCopy(TempFile, Programa);
Icon.Handle := ExtractIcon(HInstance, TempFile, 0);

{Crea una instancia de TPicture}
Pic := TPicture.Create;
{Asigna el icon.handle a la propiedad Pic.icon}

Pic.Icon := Icon;

{Configura el tamano del bitmap como el del icono y el del segundo
bitmap con el tamano del boton}
oBitmap := TBitMap.create;
oBitmap2 := TBitMap.create;
oBitmap2.Width := Icon.Width;
oBitmap2.Height := Icon.Height;
oBitmap.Width := boton.Width-4;
oBitmap.Height := boton.Height-4;

{ Dibuja el icono en el bitmap }
oBitmap2.Canvas.Draw( 0, 0, Pic.Graphic );
rBoton.left := 1;
rBoton.Top := 1;
rBoton.right:= boton.Width-6;
rBoton.Bottom := boton.Height-6;
oBitmap.Canvas.StretchDraw(rBoton, oBitmap2);

Boton.Hint := Programa;

NombreBitmap := Copy(programa, 1, Length(programa)-3)+'BMP';
{Salva el bitmap en un fichero}
If Not FileExists(NombreBitmap) Then
begin
oBitmap.SaveToFile(ExtractFilePath(Application.ExeName)+ExtractFileName(NombreBitmap));
Boton.Glyph := oBitmap;
end
else
{Carga el BMP en el boton}
Boton.Glyph.LoadFromFile(ExtractFilePath(Application.ExeName)+ExtractFileName(NombreBitmap));

finally
Icon.Free;
oBitmap.Free;
oBitmap2.Free;
screen.cursor := crDefault;

end; {main begin}
end;  {llenaboton}
procedure LimpiaBoton(boton: TSpeedButton);
var
oBitmap : TBitmap;
rBoton : TRect;
begin

try
{Configuara el tamano del bitmap como el del icono y el del segundo
bitmap con el tamano del boton}
oBitmap := TBitMap.create;
oBitmap.Width := boton.Width-4;
oBitmap.Height := boton.Height-4;
Boton.Glyph := oBitmap;

finally
oBitmap.Free;
end; {main begin}
end;  {limpiaboton}

end.

[001805]


Delphi 1

Добавление даты и времени в компонент Memo

{ Следующий код вставляет значение даты/времени в memo-поле. }

Var
s : string ;
begin
s :=  DateToStr( Date ) + ' ' + TimeToStr( Time ) + '  :' ;
Memo1.Lines.Insert( 0,  s ) ;
Memo1.SetFocus ;
Memo1.SelStart := Length( s ) ;
Memo1.SelLength := 0 ;

[001390]


Delphi 1

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

function Easter (Year: Integer): TDateTime;
{----------------------------------------------------------------}
{ Вычисляет и возвращает день Пасхи определенного года.          }
{ Идея принадлежит Mark Lussier, AppVision <MLussier@best.com>.  }
{ Скорректировано для предотвращения переполнения целых, если по }
{ ошибке передан год с числом 6554 или более.                    }
{----------------------------------------------------------------}
var
nMonth, nDay, nMoon, nEpact, nSunday,
nGold, nCent, nCorx, nCorz: Integer;
begin
{ Номер Золотого Года в 19-летнем Metonic-цикле: }
nGold := (Year mod 19) + 1;
{ Вычисляем столетие: }
nCent := (Year div 100) + 1;
{ Количество лет, в течение которых отслеживаются високосные года... }
{ для синхронизации с движением солнца: }
nCorx := (3 * nCent) div 4 - 12;
{ Специальная коррекция для синхронизации Пасхи с орбитой луны: }
nCorz := (8 * nCent + 5) div 25 - 5;
{ Находим воскресенье: }
nSunday := (Longint(5) * Year) div 4 - nCorx - 10;
{ ^ Предохраняем переполнение года за отметку 6554}
{ Устанавливаем Epact - определяем момент полной луны: }
nEpact := (11 * nGold + 20 + nCorz - nCorx) mod 30;
if nEpact < 0 then
nEpact := nEpact + 30;
if ((nEpact = 25) and (nGold > 11)) or (nEpact = 24) then
nEpact := nEpact + 1;
{ Ищем полную луну: }
nMoon := 44 - nEpact;
if nMoon < 21 then
nMoon := nMoon + 30;
{ Позиционируем на воскресенье: }
nMoon := nMoon + 7 - ((nSunday + nMoon) mod 7);
if nMoon >l 31 then
begin
nMonth := 4;
nDay   := nMoon - 31;
end
else
begin
nMonth := 3;
nDay   := nMoon;
end;
Easter := EncodeDate(Year, nMonth, nDay);
end; {Easter}

[001392]


Delphi 1

Преобразование даты в количество секунд

EncodeDate возвращает объект TDateTime, который просто является double-числом. Для получения количества миллисекунд с даты 1/1/0001, умножьте результат на 86400000.0 Но чтобы избежать переполнения, лучше пользоваться более поздней датой. [001394]


Delphi 1

Преобразование даты в неделю

procedure TForm1.Button1Click(Sender: TObject);
var  frstDay,toDay : TDateTime;  week : Integer;
begin
frstDay := StrToDate('1/1/96');
toDay := StrToDate(Edit1.Text);
week := Trunc((toDay - frstDay) / 7) + 1;
Label1.Caption := IntToStr(week);
end;

[001396]


Delphi 1

Преобразование даты

procedure TForm1.Button1Click(Sender: TObject);
var
st,
formatsave : string;
DT         : TDateTime;
begin
st := Edit1.text; // '1996-06-03 00.00.00'
formatsave := ShortDateFormat;
ShortDateFormat := 'yyyy.mm.dd hh.mm.ss';
while pos ('-', st) > 0 do
st [pos ('-', st)] := '.';
DT := StrToDateTime (st);
ShortDateFormat := formatsave;
Label1.Caption := DateTimeToStr (DT);
end;

[001397]


Delphi 1

Преобразование даты - добавление столетия

LongDate := FormatDateTime('ddmmyyyy', StrToDate(ShortDate));

Данный код преобразует дату, переданную в формате, определенном в виде короткой даты в Панели Управления (типа DD/MM/YY) в формат, заданный в строке Format (в нашем примере DDMMYYYY).

Если DD/MM/YY - входное поле, а DDMMYYYY - поле базы данных, то приведенный выше код может сослужить пользователю хорошую службу, если он вдруг захочет использовать другой формат даты, с его соответствующим переопределением в Панели Управления.

(Естественно, YYYYMMDD для поля базы данных при обычных обстоятельствах будет лучше чем DDMMYYYY, поскольку в настоящее время используется метод последовательной сортировки). [001398]


Delphi 1

Приведение даты

procedure TForm1.MaskEdit1Exit(Sender: TObject);
var
y, m, d : word;
begin
decodedate(strtodate(maskedit1.text) +  11, y, m, d);
maskedit2.text := inttostr(m) + '/' + inttostr(d) + '/' + inttostr(y);
end;

[001400]


Delphi 1

Даты и недели

У меня есть программа, которая делает примерно то, что вы хотите. Она сообщает для даты текущую неделю и день недели. Вам необходимо лишь реализовать вычисление предела для дат недели. Кроме того, формат в этом коде для дат задан в виде "06/25/1996".

Вы должны создать форму с именем "Forma", компонентом TEdit с именем "Edit1", четырьмя метками и кнопкой с именем "GetWeekBtn". Убедитесь в том, что обработчиком события формы OnCreate является метод FormCreate.

Надеюсь, что помог вам.

unit Forma;

interface

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

type
TForma1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
GetWeekBtn: TButton;
Label4: TLabel;
procedure GetWeekBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Function HowManyDays(pYear,pMonth,pDay:word):integer;
public
{ Public declarations }
end;
var
Forma1: TForma1;

implementation

{$R *.DFM}
Uses Inifiles;

procedure TForma1.FormCreate(Sender: TObject);
var       WinIni:TInifile;
begin
WinIni:=TIniFile.Create('WIN.INI');
WinIni.WriteString('intl','sShortDate','MM/dd/yyyy');
WinIni.Free;
end;

Function TForma1.HowManyDays(pYear,pMonth,pDay:word):integer;
var      Sum:integer;
pYearAux:word;
begin
Sum:=0;
if pMonth>1  then Sum:=Sum+31;
if pMonth>2  then Sum:=Sum+28;
if pMonth>3  then Sum:=Sum+31;
if pMonth>4  then Sum:=Sum+30;
if pMonth>5  then Sum:=Sum+31;
if pMonth>6  then Sum:=Sum+30;
if pMonth>7  then Sum:=Sum+31;
if pMonth>8  then Sum:=Sum+31;
if pMonth>9  then Sum:=Sum+30;
if pMonth>10 then Sum:=Sum+31;
if pMonth>11 then Sum:=Sum+30;

Sum:=Sum + pDay;
if ((pYear - (pYear div 4)*4)=3D0) and
(pMonth>2)then
inc(Sum);

HowManyDays:=Sum;
end;   { HowManyDays }
procedure TForma1.GetWeekBtnClick(Sender: TObject);
var
ADate: TDateTime;
EditAux:String;
Week,year,month,day:Word;
begin
EditAux:=Edit1.Text;
ADate := StrToDate(EditAux);
Label1.Caption := DateToStr(ADate);
DecodeDate(Adate,Year,Month,Day);

Case DayOfWeek(ADate) of
1: Label4.Caption:='Воскресенье';
2: Label4.Caption:='Понедельник';
3: Label4.Caption:='Вторник';
4: Label4.Caption:='Среда';
5: Label4.Caption:='Четверг';
6: Label4.Caption:='Пятница';
7: Label4.Caption:='Суббота';
end
Week:=(HowManyDays(year,month,day) div 7) +1;

Label3.Caption:='Неделя No. '+IntToStr(Week);
end;

end.

[001401]


Delphi 1

Количество дней между двумя датами I

ПЕРЕМЕННЫЕ:

Year1, Month1, Day1,
Year2, Month2, Day2,
YearResult, MonthResult, DayResult: Word;
TDay1, TDay2, DateDiff: TDateTime;

КОД:

TDay1 := EncodeDate(Year1, Month1, Day1);
TDay2 := EncodeDate(Year2, Month2, Day2);
DateDiff := TDay2 - TDay1; {предположим, что TDay2 позднее, чем TDay1}
DecodeDate(DateDiff, YearResult, MonthResult, DayResult);

DateDiff имеет тип LongInt (хотя и является объектом TDateTime), и содержит количество дней между датами. [001402]


Delphi 1

Количество дней между двумя датами II

Для DateDiff:

Вы смотрели на функцию DecodeDate? Это не точно именно то, что вам нужно, но на ее основе можно сделать вашу функцию именно с нужной вам функциональностью.

Для величины Present:

function PresentValue(const cashflows : array of double;    { отсортированные
транзакции, начальный индекс - cashflows[0] }
n : integer; { количество транзакций в массиве }
rate : double; { оценочный процент за истекший период }
atbegin : boolean) : double; { true, если транзакция была в начале периода,
false если в конце }
var
i         : integer;
factor    : double;
begin
factor := (1 + rate / 100.0);
result := 0;
for i := n - 1 downto 0 do
result := (result + cashflows[n]) / factor;
if atbegin then
result := result * factor;
end;

[001404]


Delphi 1

Конвертирование даты

TheDateField.AsString := TheDateString;
TheDateString := TheDateField.AsString;

это делает преобразование подобно DateToStr и StrToDate. Аналогично:

TheDateField.AsDateTime := StrToDate(TheDateString);
TheDateString := DateToStr(TheDateField.AsDateTime);

[001406]


Delphi 1

Число текущей недели

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

{***************************************************************************}
function kcIsLeapYear( nYear: Integer ): Boolean;
begin
Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod
400 = 0)); end;

{***************************************************************************}
function kcMonthDays( nMonth, nYear: Integer ): Integer;
const
DaysPerMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31,
31, 30, 31, 30, 31);
begin
Result := DaysPerMonth[nMonth];
if (nMonth = 2) and kcIsLeapYear(nYear) then Inc(Result);
end;

{***************************************************************************}
function kcWeekOfYear( dDate: TDateTime ): Integer;
var
X, nDayCount: Integer;
nMonth, nDay, nYear: Word;
begin

nDayCount := 0;

deCodeDate( dDate, nYear, nMonth, nDay );

For X := 1 to ( nMonth - 1 ) do
nDayCount := nDayCount + kcMonthDays( X, nYear );

nDayCount := nDayCount + nDay;

Result := ( ( nDayCount div 7 ) + 1 );

end;

[001410]


Delphi 1

Разница во времени

...я не знаю, когда вы выполняете TimeTaken.. Вы делали какую-нибудь паузу перед запуском TimeTaken после выполнения SetTimeStart? Если не делали, то удивительно, что tt=Now.. Я пробовал ваш код с несколькими незначительными изменениями... и я всегда получал разницу между Now и TimeStart. Но я объявляю tt как TDateTime, а не как Double, и использую событие OnTimer для запуска процедуры TimeTaken. Вы можете проверить это, запустив пример, приведенный ниже.

{*******************************************************************
ФАЙЛ : TIMEEX.PAS
ПРИМЕЧАНИЕ : Создайте форму, содержащую 1 TTimer и 6 TLabel. Установите событие OnTimer у TTimer на TForm.Timer1.Timer
********************************************************************}
 unit Time;

interface

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

type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel;           {Caption : 'Старт :'}
Label2: TLabel;
Label3: TLabel;           {Caption : 'Время : '}
Label4: TLabel;
Label5: TLabel;           {Caption : 'Истекшее время:'}
Label6: TLabel;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
TimeStart : TDateTime;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
TimeStart := Now;
Label2.Caption := TimeToStr(Now);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
tt : TDateTime;
begin
Label4.Caption := TimeToStr(Now);
tt:= Now - TimeStart;
Label6.Caption:= TimeToStr(tt);
end;

end.

[001413]


Delphi 1

Проблема со временем

...я нашел Time24Hour в файлах помощи, как вы и советовали. Но...

вот код для EncodeTime в SysUtils.Pas file:

function DoEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
begin
Result := False;
if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
begin
Time := (LongMul(Hour * 60 + Min, 60000) + Sec * 1000 + MSec) / MSecsPerDay;
Result := True;
end;
end;

function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;
begin
if not DoEncodeTime(Hour, Min, Sec, MSec, Result) then
ConvertError(LoadStr(STimeEncodeError));
end;

Как вы можете видеть, проверка Time24Hour присутствует. Я думал в Browser все будет также. Ничего подобного! Я уж грешным делом подумал, что Time24Hour объявили устаревшим, исключили из поддержки, выбросили частично из кода, но забыли почистить файл помощи. Вы так не думаете? [001415]


Delphi 1

Переменная времени

Используйте переменную типа TDateTime.

procedure TForm1.XXXXXXXClick(Sender: TObject);
var StartTime, EndTime, ElapsedTime :TDateTime;
begin
StartTime := Now;
{Здесь поместите свой код}
EndTime := Now;
ElapsedTime := EndTime - StartTime;
Label1.Caption := TimeToStr(ElapsedTime);
end;

{теперь все это в памяти, но в нашем случае это хорошее место. }
var
before,
after,
elapsed : TDateTime;
Ehour, Emin, Esec, Emsec : WORD;
...

before := now;

some_process();

after := now;
elapsed := after - before;

decodetime(elapsed, Ehour, Emin, Esec, Emsec);

теперь Ehour:Emin:Esec.Emsec будет содержать истекшее время.

Это то, что я хотел. fStartWhen содержит дату/время начала процесса. (fStartWhen := NOW). OneSecond - константа, определенная как 1/24/3600. (Да, эта программа может выполняться для нескольких дней. Но даже самый быстрый P5 может не справиться с большим количеством данных!)

PROCEDURE        TformDBLoad.UpdateTime;
VAR        Delta        :TDateTime

BEGIN
fLastUpdate := NOW
IF ABS( fStartWhen - fLastUpdate ) < OneSecond THEN EXIT
Delta := fLastUpdate - fStartWhen
doElapsedTime.Caption := FORMAT( '%1. дней из %s',
[INT(Delta),FORMATDATETIME('hh:nn:ss', FRAC(Delta))] )
END;

[001417]


Delphi 1

Алгоритм вычисления дня недели для Delphi1

Начиная с Delphi2 в модуле SysUtils определена функция DayOfWeek(Date: TDateTime): Integer.

Тип TDateTime в Delphi1 определён как Double, дата это целая часть определяющая количество дней прошедших с 01.01.0001, дробная часть содержит время.

(*******************************************************************************
Функция возвращает номер дня недели от 0 - Воскресенье до 6 - Суббота
*******************************************************************************)
function DayOfWeek(Date:TDateTime):Integer;
begin
Result:=Trunc(Date) mod 7;
end;

(*******************************************************************************
Функция возвращает название дня недели
*******************************************************************************)
 function NameDayOfWeek(Date:TDateTime):String;
const
DayNames:array[0..6] of String[11]=('Воскресенье',
'Понедельник',
'Вторник',
'Среда',
'Четверг',
'Пятница',
'Суббота');
begin
Result:=DayNames[DayOfWeek(Date)];
end;

С уважением Бахтинов Андрей [001603]


Письмо читателя

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

Олегом Кулабухов отвечает:

В примере главную роль играет GetSystemTime()

procedure TForm1.Button1Click(Sender: TObject);
var
lt : TSYSTEMTIME;
st : TSYSTEMTIME;
begin
GetLocalTime(lt);
GetSystemTime(st);
Memo1.Lines.Add('LocalTime = ' +
IntToStr(lt.wmonth) + '/' +
IntToStr(lt.wDay) + '/' +
IntToStr(lt.wYear) + ' ' +
IntToStr(lt.wHour) + ':' +
IntToStr(lt.wMinute) + ':' +
IntToStr(lt.wSecond));
Memo1.Lines.Add('UTCTime = ' +
IntToStr(st.wmonth) + '/' +
IntToStr(st.wDay) + '/' +
IntToStr(st.wYear) + ' ' +
IntToStr(st.wHour) + ':' +
IntToStr(st.wMinute) + ':' +
IntToStr(st.wSecond));
end;

[001825]


Простой пример XOR шифрования

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

Вот ужасно простой пример XOR шифрования - работает без глюков.

var key, text, longkey, result : string;
i : integer;
toto, c : char;
begin
for i := 0 to (length(text) div length(key)) do
longkey := longkey + key;

for i := 1 to length(text) do begin
toto := chr((ord(text[i]) XOR ord(longkey[i]))); // XOR алгоритм
result := result + toto;
end;
end;

Igor N. Semenushkin. [001832]


Как научить Delphi делать правильное округление дробных чисел?

Nomadic советует:

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

Function RoundStr(Zn:Real;kol_zn:Integer):Real;
{Zn-значение; Kol_Zn-Кол-во знаков после запятой}
Var snl,s,s0,s1,s2:String; n,n1:Real;
nn,i:Integer;
begin
s:=FloatToStr(Zn);
if (Pos(',',s)>0) and (Zn>0) and
(Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn)
then
begin
s0 := Copy(s,1,Pos(',',s)+kol_zn-1);
s1 := Copy(s,1,Pos(',',s)+kol_zn+2);
s2 := Copy(s1,Pos(',',s1)+kol_zn,Length(s1));
n := StrToInt(s2)/100;
nn := Round(n);
if nn >= 10 then
begin
snl := '0,';
For i := 1 to kol_zn - 1 do snl := snl + '0';
snl := snl+'1';
n1 := StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl);
s := FloatToStr(n1);
if Pos(',',s) > 0 then s1 := Copy(s,1,Pos(',',s)+kol_zn);
end
else s1 := s0 + IntToStr(nn);
if s1[Length(s1)]=',' then s1 := s1 + '0';
Result := StrToFloat(s1);
end
else Result := Zn;
end;

Все-таки работа со строками здесь излишество -

function RoundEx( X: Double; Precision : Integer ): Double;
{Precision : 1 - до целых, 10 - до десятых, 100 - до сотых...}
var
ScaledFractPart, Temp : Double;
begin
ScaledFractPart := Frac(X)*Precision;
Temp := Frac(ScaledFractPart);
ScaledFractPart := Int(ScaledFractPart);
if Temp >= 0.5 then ScaledFractPart := ScaledFractPart + 1;
if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1;
RoundEx := Int(X) + ScaledFractPart/Precision;
end;

[001146]


Генерация еженедельных списков задач

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

Мне нужен простой алгоритм, чтобы решить эту проблему. Какие идеи?

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

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
ListBox1: TListBox;
Edit1: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const
maxTeams = 100;
var
Teams: Array[1..maxTeams] of integer;
nTeams,ix,week,savix: integer;

function WriteBox(week: integer):string;
var
str: string;
ix: integer;
begin
Result := Format('Неделя=%d ',[week]);
for ix := 1 to nTeams do begin
if odd(ix) then Result := Result+' '
else Result := Result+'v';
Result := Result+IntToStr(Teams[ix]);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
nTeams := StrToInt(Edit1.Text);
if Odd(nTeams) then inc(nTeams);  {должны иметь номера каждой группы}
ListBox1.Clear;
for ix := 1 to nTeams do Teams[ix] := ix;
ListBox1.Items.Add(WriteBox(1));

for week := 2 to nTeams-1 do begin
Teams[1] := Teams[nTeams-1]; {используем Teams[1] в качестве временного хранилища}
for ix := nTeams downto 2 do
if not Odd(ix) then begin
savix := Teams[ix];
Teams[ix] := Teams[1];
Teams[1] := savix;
end;
for ix := 3 to nTeams-1 do
if Odd(ix) then begin
savix := Teams[ix];
Teams[ix] := Teams[1];
Teams[1] := savix;
end;
Teams[1] := 1; {восстанавливаем известное значение}
ListBox1.Items.Add(WriteBox(week));
end;
end;

end.

- Mike Orriss [001058]


Генерация случайного пароля

The_Sprite советует:

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

Совместимость: Delphi 5.x (или выше)

Собственно сам исходничек: Пароль создаётся из символов, содержащихся в таблице.

Внимание: Длина пароля должна быть меньше, чем длина таблицы!

// запускаем генератор случайных чисел (только при старте приложения). procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;
function RandomPwd(PWLen: integer): string;
// таблица символов, используемых в пароле
const StrTable: string =
'!#$%&/()=?@<>|{[]}\*~+#;:.-_' +
'ABCDEFGHIJKLMabcdefghijklm' +
'0123456789' +
'ДЦЬдцьЯ' +
'NOPQRSTUVWXYZnopqrstuvwxyz';
var
N, K, X, Y: integer;
begin
// проверяем максимальную длину пароля
if (PWlen > Length(StrTable)) then K := Length(StrTable)-1
else K := PWLen;
SetLength(result, K); // устанавливаем длину конечной строки
Y := Length(StrTable); // Длина Таблицы для внутреннего цикла
N := 0; // начальное значение цикла
while N < K do begin // цикл для создания K символов
X := Random(Y) + 1; // берём следующий случайный символ
// проверяем присутствие этого символа в конечной строке
if (pos(StrTable[X], result) = 0) then begin
inc(N); // символ не найден
Result[N] :=
StrTable[X]; // теперь его сохраняем
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
cPwd: string;
begin
// вызываем функцию генерации пароля из 30 символов
cPwd := RandomPwd(30);
// ...
end;

[001379]


Delphi 1

Проверка ISBN

ISBN (или International Standard Book Numbers, международные стандартные номера книг) - мистические кодовые числа, однозначно идентифицирующие книги. Цель этой статьи заключается в том, чтобы убрать покров таинственности, окружающий структуру ISBN, и в качестве примера разработать приложение, проверяющее правильность создания кода-кандидата на ISBN.

ISBN имеет длину тринадцать символов, которые ограничиваются в использовании символами-цифрами от "0" до "9", дефисом, и буквой "X". Этот тринадцатисимвольный код состоит из четырех частей (между которыми располагается дефис): идентификатор группы, идентификатор издателя, идентификатор книги для издателя, и контрольная цифра. Первая часть (идентификатор группы) используется для обозначения страны, географического региона, языка и пр.. Вторая часть (идентификатор издателя) однозначно идентифицирует издателя. Третья часть (идентификатор книги) однозначно идентифицирует данную книгу среди коллекции книг, выпущенных данным издателем. Четвертая, заключительная часть (контрольная цифра), используется в коде алгоритме другими цифрами для получения поддающегося проверке ISBN. Количество цифр, содержащееся в первых трех частях, может быть различным, но контрольная цифра всегда содержит один символ (расположенный между "0" и "9" включительно, или "X" для величины 10), а само ISBN в целом имеет длину тринадцать символов (десять чисел плюс три дефиса, разделяющих три части ISBN).

ISBN 3-88053-002-5 можно так разложить на части:

  Группа:            3
  Издатель:          88053
  Книга:             002
  Контрольная цифра: 5
ISBN можно проверить на правильность кода, используя простой математический алгоритм. Суть его в следующем: нужно взять каждую из девяти цифр первых трех частей ISBN (пропуская нечисловые дефисы), умножить каждую отдельную цифру на число цифр, стоящих слева от позиции числа ISBN (оно всегда будет меньше одинадцати), сложить все результаты умножения, прибавить контрольную цифру, после чего разделить получившееся число на одиннадцать. Если после деления на одинадцать никакого остатка не образуется (т.е., число по модулю 11 делится без остатка), кандидат на ISBN является верным числом ISBN. К примеру, используем предыдущий образец ISBN 3-88053-002-5:
  ISBN:              3  8  8  0  5  3  0  0  2  5
  Множитель:        10  9  8  7  6  5  4  3  2  1
  Продукт:          30+72+64+00+30+15+00+00+04+05 = 220
Поскольку 220 на одинадцать делится без остатка, расмотренный нами кандидат на IDBN является верным кодом ISBN.

Данный алгоритм проверки легко портируется в код Pascal/Delphi. Для извлечения контрольной цифры и кода из ISBN номера используются строковые функции и процедуры, после чего они передаются в функцию проверки. Контрольная цифра преобразуется в тип целого, на основе ее формируется стартовое значение составной переменной, состоящей из добавляемых цифр, умноженных на их позицию в коде ISBN (отдельные цифры, составляющие первые три части ISBN). Для последовательной обработки каждой цифры используется цикл For, в котором мы игнорируем дефисы и умножаем текущую цифру на ее позицию в коде ISBN. В заключение, значение этой составной переменной проверяется на делимость без остатка на одиннадцать. Если остатка после деления нет, код ISBN верен, если же остаток существует, то код кандидат на ISBN имеет неправильный код.

Вот пример этой методики, изложенной на языке функций Delphi:

function IsISBN(ISBN: String): Boolean;
var
Number, CheckDigit: String;
CheckValue, CheckSum, Err: Integer;
i, Cnt: Word;
begin
{Получаем контрольную цифру}
CheckDigit := Copy(ISBN, Length(ISBN), 1);
{Получаем остальную часть, ISBN минус контрольная цифра и дефис}
Number := Copy(ISBN, 1, Length(ISBN) - 2);
{Длина разницы ISBN должны быть 11 и контрольная цифра между 0 и 9, или X}
if (Length(Number) = 11) and (Pos(CheckDigit, '0123456789X') > 0) then
begin
{Получаем числовое значение контрольной цифры}
if (CheckDigit = 'X') then
CheckSum := 10
else
Val(CheckDigit, CheckSum, Err);
{Извлекаем в цикле все цифры из кода ISBN, применяя алгоритм декодирования}
Cnt := 1;
for i := 1 to 12 do begin
{Действуем, если только текущий символ находится между "0" и "9", исключая дефисы}
if (Pos(Number[i], '0123456789') > 0) then begin
Val(Number[i], CheckValue, Err);
{Алгоритм для каждого символа кода ISBN, Cnt - n-й обрабатываемый символ}
CheckSum := CheckSum + CheckValue * (11 - Cnt);
Inc(Cnt);
end;
end;
{Проверяем делимость без остатка полученного значения на 11}
if (CheckSum MOD 11 = 0) then
IsISBN := True
else
IsISBN := False;
end
else
IsISBN := False;
end;

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


Совет читателя

Есть ли у кого алгоритм переноса русского текста по слогам?

Nomadic пишет:

Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе понимает сложные слова, но в 98% работает нормально.

{***********************************************************
*                                                          *
*           Hypernation for QuarkQPress                    *
*           written by Gorbunov A. A.                      *
*           acdc@media-press.donetsk.ua                    *
*                                                          *
************************************************************}
unit Hyper;

interface

uses
Windows,Classes,SysUtils;

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
Function SetHyphString(s : String):String;
Function MayBeHyph(p:PChar;pos:Integer):Boolean;

implementation

Type
TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec);
TSymbAR=array [0..1000] of TSymbol;
PSymbAr=^TSymbAr;

Const
HypSymb=#$1F;

Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];

GlasCHAR=['Й', 'й', 'У', 'у', 'Е', 'е','Ю', 'ю', 'А', 'а', 'О', 'о',
'Э', 'э', 'Я', 'я', 'И', 'и',
{ english }
'e',  'E', 'u',  'U','i',  'I', 'o',  'O', 'a',  'A', 'j',  'J' ];

SoglChar=['Г', 'г' , 'Ц', 'ц' ,'К', 'к' , 'Н', 'н' , 'Ш', 'ш' , 'щ', 'Щ' ,
'З', 'з' , 'Х', 'х' ,'Ф', 'ф' , 'В', 'в' , 'П', 'п' , 'Р', 'р' ,
'Л', 'л' , 'Д', 'д' ,'Ж', 'ж' , 'Ч', 'ч' , 'С', 'с' , 'М', 'м' ,
'т', 'T' , 'б', 'Б' ,
{ english }
'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s','S',
'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z','Z',
'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

SpecSign= [ 'Ы', 'ы','Ь', 'ь', 'Ъ', 'ъ'];

Function isSogl(c:Char):Boolean;
begin
Result:=c in SoglChar;
end;

Function isGlas(c:Char):Boolean;
begin
Result:=c in GlasChar;
end;

Function isSpecSign(c:Char):Boolean;
begin
Result:=c in SpecSign;
end;

Function GetSymbType(c:Char):TSymbol;
begin
if isSogl(c) then begin Result:=st_Sogl;exit;end;
if isGlas(c) then begin Result:=st_Glas;exit;end;
if isSpecSign(c) then begin Result:=st_Spec;exit;end;
Result:=st_NoDefined;
end;

Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean;
var i:Integer;
glFlag:Boolean;
begin
glFlag:=false;
for i:=Start to Len-1 do
begin
if c^[i]=st_NoDefined then begin Result:=false;exit;end;
if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start))
then
begin
Result:=True;
exit;
end;
end;
Result:=false;
end;

{ расставлялка переносов }
Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
var
HypBuff  : Pointer;
h   : PSymbAr;
i   : Integer;
len : Integer;
Cur : Integer; { Tекущая позиция в разультирующем массиве}
cw  : Integer; { Номер буквы в слове}
Lock: Integer; { счетчик блокировок}
begin
Cur:=0;
len  := StrLen(pc);
if (MaxSize=0)OR(Len=0) then
begin
Result:=nil;
Exit;
end;

GetMem(HypBuff,MaxSize);
GetMem(h,Len+1);
{ заполнение массива типов символов}
for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);
{ собственно расстановка переносов}
cw:=0;
Lock:=0;
for i:=0 to Len-1 do
begin
PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

if i>=Len-2 then Continue;
if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw);
if Lock<>0 then begin Dec(Lock);Continue;end;
if cw<=1 then Continue;
if not(isSlogMore(h,i+1,len)) then Continue;

if
(h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if (h^[i]=st_Spec) then begin
PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end;

end;
{}
FreeMem(h,Len+1);
PChar(HypBuff)[cur]:=#0;
Result:=HypBuff;
end;

Function Red_GlasMore(p:Pchar;pos:Integer):Boolean;
begin
While p[pos]<>#0 do
begin
if p[pos] in Spaces then begin Result:=False; Exit; end;
if isGlas(p[pos]) then begin Result:=True; Exit; end;
Inc(pos);
end;
Result:=False;
end;

Function Red_SlogMore(p:Pchar;pos:Integer):Boolean;
Var BeSogl,BeGlas:Boolean;
begin
BeSogl:=False;
BeGlas:=False;
While p[pos]<>#0 do
begin
if p[pos] in Spaces then Break;
if Not BeGlas then BeGlas:=isGlas(p[pos]);
if Not BeSogl then BeSogl:=isSogl(p[pos]);
Inc(pos);
end;
Result:=BeGlas and BeSogl;
end;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;
var i:Integer;
len:Integer;
begin
i:=pos;
Len:=StrLen(p);
Result:=
(Len>3)
AND
(i>2)
AND
(i<Len-2)
AND
(not (p[i] in Spaces))
AND
(not (p[i+1] in Spaces))
AND
(not (p[i-1] in Spaces))
AND
(
(isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
Red_SlogMore(p,i+1))
OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
Red_SlogMore(p,i+1)  )
OR
((isSpecSign(p[i])))
);

end;

Function SetHyphString(s : String):String;
Var Res:PChar;
begin
Res:=SetHyph(PChar(S),Length(S)*2)
Result:=Res;
FreeMem(Res,Length(S)*2);
end;

end.

[001606]


Как раскрыть строки с подстановками вида '%SystemRoot%\IOSUBSYS\'?

Nomadic советует:

Используй вызов

ExpandEnvironmentStrings( LPCTSTR lpSrc, LPTSTR lpDst, DWORD nSize );

[001084]


Delphi 1

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

Можно. Попробуйте следующий код:

Procedure settime(hour, min, sec, hundreths : byte); assembler;
asm
mov  ch, hour
mov  cl, min
mov  dh, sec
mov  dl, hundreths
mov  ah, $2d
int  $21
end;

Procedure setdate(Year : word; Month, Day : byte); assembler;
asm
mov  cx, year
mov  dh, month
mov  dl, day
mov  ah, $2b
int  $21
end;

[001411]


Delphi 1

Определение завершения работы Windows

НОМЕР ДОКУМЕНТА: TI3133
ПРОДУКТ: Delphi
Версия: 1.0
ОС: Windows
Дата: 1 октября, 1996
Тема: Определение завершения работы Windows

Существует ли возможность определения завершения работы Windows для нормального завершения работы работающего приложения Delphi?

Самым простым решением является создание обработчика события главной формы OnCloseQuery. Данное событие возникает как результат сообщения WM_QUERYENDSESSION, которое посылается всем работающим приложениям Windows в момент инициализации процесса окончания работы Windows. Логическая переменная CanClose, передаваемая обработчику как var-параметр, может позволить программе (и Windows) завершить свою работу, если имеет значение True, значение же False не позволит программе завершить свою работу.

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

Демонстрационный код

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
{Спрашиваем пользователя, если инициировано завершение работы.}
if MessageDlg('Вы уверены?', mtConfirmation, mbYesNoCancel, 0) = mrYes
then CanClose := true    {Разрешаем завершение работы.}
else CanClose := false;  {Не разрешаем завершение работы.}
end;

[001063]


Как консольное приложение может узнать, что Винды завершаются?

Nomadic рекомендует следующий код:

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

BOOL Ctrl_Handler( DWORD Ctrl )
{
  if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) )
  {
    // Вау! Юзер обламывает!
  }
  else
  {
    // Тут что-от другое можно творить. А можно и не творить :-)
  }
  return TRUE;
}
function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
begin
// Вау, вау
end
else
begin
// Am I creator?
end;
Result := true;
end;

А где-то в программе:

SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

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

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть. [001152]


Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна?

Nomadic рекомендует следующий способ:

Используй GetMessage(), в качестве HWND окна пиши NULL (на Паскале - 0). Если в очереди сообщений следующее - WM_QUIT, то эта функция фозвращает FALSE. Если ты пишешь программу для Win32, то запихни это в отдельный поток, организующий выход из программы. [001232]


Постепенное умирание

The_Sprite пишет:

Вопрос: А как реализовать в одном компоненте такие функции как выключение компьютера, перезагрузка, завершение сеанса работы пользователя, Eject CD, выключение питания монитора и т.д.? Ответ: предлагаем посмотреть следующий пример ...

Совместимость: все версии Delphi

Пример:

procedure TForm1.Button1Click(Sender: TObject);

begin
PowerControl1.Action:=actCDEject;// Или... actLogOFF, actShutDown...
PowerControl1.Execute;
end;

Component Code:

unit
PowerControl;
interface
uses WinTypes, WinProcs, Messages,
SysUtils, Classes, Controls,
Forms, Graphics,
MMSystem;
type
TAction =
(actLogOFF,actShutDown,actReBoot,actForce,actPowerOFF,

actForceIfHung,actMonitorOFF,actMonitorON,actCDEject,actCDUnEject);

type
TPowerControl = class(TComponent)

private

FAction : TAction;

procedure
SetAction(Value : TAction);
protected

public

function Execute :
Boolean;
published

property Action :
TAction read FAction write SetAction;
end;

procedure Register;
implementation
procedure
Register;
begin
RegisterComponents('K2',
[TPowerControl]);
end;
procedure TPowerControl.SetAction(Value
: TAction);
begin
FAction := Value;

end;
function TPowerControl.Execute : Boolean;
begin

with (Owner as TForm) do

case FAction of

actLogOff:
ExitWindowsEx(EWX_LOGOFF,1);

actShutDown:
ExitWindowsEx(EWX_SHUTDOWN,1);

actReBoot:
ExitWindowsEx(EWX_REBOOT,1);

actForce:
ExitWindowsEx(EWX_FORCE,1);

actPowerOff:
ExitWindowsEx(EWX_POWEROFF,1);

actForceIfHung:
ExitWindowsEx(EWX_FORCEIFHUNG,1);

actMonitorOFF:
SendMessage(Application.Handle,

WM_SYSCOMMAND,
SC_MONITORPOWER, 0);

actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND,

SC_MONITORPOWER, -1);

actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN

WAIT',nil,0, Handle);

actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED

WAIT',nil,0, Handle);
end; {Case}

Result := True;
end;
end.

[001539]


Как выполнить shutdown для удалённого компьютера?

Nomadic делится сиплюсплюсным кодом:

int main(int argc, char **argv)
{
HANDLE hToken;
TOKEN_PRIVILEGES tkp;
//-------------------
 char *name="";    // address of name of computer to shut down
 char *msg="";     //address of message to display in dialog box
 DWORD time=0;     // time to display dialog box
 bool force=true;  // force applications with unsaved changes flag
 bool reboot=true; //reboot flag
//---------------------------------------------------------------------

    OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
&hToken);

    if(!LookupPrivilegeValue(name, SE_SHUTDOWN_NAME,&tkp.Privileges[0].Luid)){
    printf ("SE_SHUTDOWN_NAME Privilege облом \n");
    return 1 ;};

    tkp.PrivilegeCount =1;
    tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
    AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,(PTOKEN_PRIVILEGES)NULL, 0);

    if(!LookupPrivilegeValue(name,
SE_REMOTE_SHUTDOWN_NAME,&tkp.Privileges[0].Luid)){
    printf("SE_REMOTE_SHUTDOWN_NAME Privilege облом \n");
    return 2 ;};

    tkp.PrivilegeCount =1;
    tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
    AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,(PTOKEN_PRIVILEGES)NULL, 0);

    if (InitiateSystemShutdown(name,msg,time,force,reboot))
    printf("%s shutdown Ok\n",name);
    else printf("Can't shutdown %s \n",name);

 return 0;
}
//***************************************************************************//
[001587]


Как перегрузить Windows?

Nomadic делится своим опытом:

1) ExitWinndowsEx(EWX_FORCE+EWX_REBOOT,0)
2) mov  al,0F0h
    out  64h,al
[001718]


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

Игорь Пролис рекомендует следующий код:

{*******************************************************}
{                                                       }
{                     HTMLCoolEdit                      }
{                                                       }
{           Copyright (c) 1999-2000 PROFOX              }
{                                                       }
{*******************************************************}
unit multinst;

interface

uses Forms, Windows, Dialogs, SysUtils;

const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;

function GetMIError: Integer;
function InitInstance : Boolean;

implementation

uses RegWork, FileWork;

var
UniqueAppStr : PChar;
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
Result := 1;
if Msg = MessageID then begin
if IsIconic(Application.Handle) then OpenIcon(Application.Handle)
else SetForegroundWindow(Application.Handle);
FileWork.LoadFileName(RegWork.RWGetParamStr1);
end
else Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;

procedure SubClassApplication;
begin
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;
begin
Application.ShowMainForm := False;
PostMessage(HWND_BROADCAST, MessageId,0,0);
end;

function InitInstance : Boolean;
begin
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then begin
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm:=True;
DoFirstInstance;
result := True;
end else begin
RegWork.RWSetParamStr1;
BroadcastFocusMessage;
result := False;
end;
end;

initialization
begin
UniqueAppStr := PChar(Application.ExeName);
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.

[001011]


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

YoungHacker рекомендует следующий код:

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

Поиск окон и создание их нарываются на те-же проблемы. Из RxLib Функция тоже не обходит этой ситуации.

Мой вариант немного дорабатывает уже значительно переработанное то что предоставили разработчики Delphi 2 Пачека (Pacheco) и Тайхайра (Teixeira). и находится в файле TPrevInstUnit. В файле проекта пишется следующий вызов:

begin
//- Найти предыдущую версию программы
if (InitInstance) then begin
....
Application.Initialize;
....
Application.CreateForm(.....);
....
Application.Run;
end;
end.

Файл TPrevInstUnit

unit TPrevInstUnit;

interface

uses Forms, Windows, Dialogs, SysUtils;

function InitInstance : Boolean;

implementation

const
UniqueAppStr : PChar = #0;   // Различное для каждого приложения
// Но одинаковое для каждой копии программы
var
MessageId : Integer;
OldWProc : TFNWndProc = Nil;
MutHandle : THandle = 0;
SecondExecution : Boolean = False;

function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall;
begin
//- Если это - сообщение о регистрации... }
if (Msg = MessageID) then begin
//- если основная форма минимизирована
if IsIconic(Application.Handle) then begin
//- восстанавливаем ее
Application.Restore;
end else begin
//- вытаскиваем на перед
ShowWindow(Application.Handle, SW_SHOW);
SetForegroundWindow(Application.Handle);
Application.BringToFront;
end;
Result := 0;
end else
{ В противном случае посылаем сообщение предыдущему окну }
Result := CallWindowProc(OldWProc, Handle, Msg, wParam, lParam);
end;

function InitInstance : Boolean;
var
BSMRecipients: DWORD;
begin
Result := False;

//- пробуем открыть MUTEX созданный предыдущей копией программы
MutHandle := CreateMutex(Nil, True, UniqueAppStr);

//- Мутекс уже был создан ?
SecondExecution := (GetLastError = ERROR_ALREADY_EXISTS);

if (MutHandle = 0) then begin
ShowMessage('Ошибка создания Mutex.');
Exit;
end;

if Not (SecondExecution) then begin
//- назначаем новый обработчик сообщений приложения, а старый сохраняем
OldWProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc)));
//- если обработчик не найден устанавливаем ошибку
if (OldWProc = Nil) then begin
ShowMessage('Ошибка поиска стандартного обработчика сообщений приложения.');
Exit;
end;

//- Установить "нормальный" статус основного окна приложения
ShowWindow(Application.Handle, SW_ShowNormal);
//- покажем основную форму приложения
Application.ShowMainForm := True;
//- все нормально мама трын тин тин тин тири тын тын
Result := True;
end else begin
//- установить статус окна приложения "невидимый"
ShowWindow(Application.Handle, SW_Hide);
//- Не покажем основную форму приложения
Application.ShowMainForm := False;
//- Посылаем другому приложению сообщение и информируем о необходимости
// перевести фокус на себя
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0);
end;
end;

initialization
begin
//- Создать ункальную строку для опознания приложения
UniqueAppStr := PChar('YoungHackerNetworkDataBaseProgramm');
//- Зарегистрировать в системе уникальное сообщение
MessageID := RegisterWindowMessage(UniqueAppStr);
end;

finalization
begin
if (OldWProc <> Nil) then
{ Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldWProc));
end;

end.

[001032]


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

Nomadic рекомендует следующий код:

FindWindow является неполным решением (если меняется заголовок окна или если есть другая программа с таким же заголовком или типом окна).

Вторично: Это работает медленно.

Правильно - использовать обьекты синхронизации Win32 API.

Лениво пользовать семафоры, покажу на именованных мутексах (семафоры с двумя состояниями).

Unit OneInstance32;

interface

implementation

uses
Forms;

var
g_hAppMutex: THandle;

function OneInstance: boolean;
var
g_hAppCritSecMutex: THandle;
dw: Longint;
begin
g_hAppCritSecMutex := CreateMutex( nil, true, PChar(Application.Title + '.OneInstance32.CriticalSection') );

// if GetLastError - лениво писать
g_hAppMutex := CreateMutex( nil, false, PChar(Application.Title + 'OneInstance32.Default') );

dw := WaitForSingleObject( g_hAppMutex, 0 );

Result := (dw <> WAIT_TIMEOUT);

ReleaseMutex( g_hAppCritSecMutex ); // необязательно вследствие последующего закрытия
CloseHandle( g_hAppCritSecMutex );

end;

initialization

g_hAppMutex := 0;

finalization

if LongBool( g_hAppMutex ) then
begin
ReleaseMutex( g_hAppMutex); // необязательно
CloseHandle( g_hAppMutex );
end;

end.

[001170]


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

Михаил Чумак рекомендует следующий код:

Есть такая штука Atom (см. Help).

program SelfCheck;

uses
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};

const
AtStr='MyProgram';

function CheckThis : boolean;
var
Atom: THandle;
begin
Atom:= GlobalFindAtom(AtStr);
Result:= Atom <> 0;
if not result
then GlobalAddAtom(AtStr);
end;

begin
if not CheckThis
then begin // Запуск программмы
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
GlobalDeleteAtom(GlobalFindAtom(AtStr)); // !!!
end
else begin
MessageBox(0,'Нельзя запустить две копии','Моя программа',0);
end;
end.

Элегантно и работает однозначно. Спасибо Славе Шубину. [001425]


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

Nomadic рекомендует следующее:

A: Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для завершения второго экземпляра используйте Application.Terminate.

(AS): Другой вариант: X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция IsMonitorRunning(). [001506]


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

Своим опытом делится Олег Кулабухов:

Самый простой, но немного некорректный способ - найти заголовок окна по FindWindow() и выполнять какие-либо действия в зависимости от того, есть ли такое окно или нет. Второй выриант - через определение мутексов. Если определить мутекс не удастся - всем окнам передается системное сообщение.

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

{The code for OneInstance.dpr}

program OneInstance;

uses
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

begin
{Attempt to create a named mutex}
CreateMutex(nil, false, 'MyApp');
{if it failed then there is another instance}
if GetLastError = ERROR_ALREADY_EXISTS then begin
{Send all windows our custom message - only our other}
{instance will recognise it, and restore itself}
 SendMessage(HWND_BROADCAST,
RegisterWindowMessage('MyApp'),
0,
0);
{Lets quit}
Halt(0);
end;
Application.Initialize;
{Tell Delphi to un-hide it's hidden application window}
{This allows our instance to have a icon on the task bar}
 Application.ShowMainForm := true;
ShowWindow(Application.Handle, SW_RESTORE);
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

{The code for unit1.pas}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
OldWindowProc : Pointer; {Variable for the old windows proc}
MyMsg : DWord; {custom systemwide message}

function NewWindowProc(WindowHandle : hWnd;
TheMessage : LongInt;
ParamW : LongInt;
ParamL : LongInt) : LongInt stdcall;
begin
if TheMessage = MyMsg then begin
{Tell the application to restore, let it restore the form}
SendMessage(Application.handle, WM_SYSCOMMAND, SC_RESTORE, 0);
SetForegroundWindow(Application.Handle);
{We handled the message - we are done}
Result := 0;
exit;
end;
{Call the original winproc}
Result := CallWindowProc(OldWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Register a custom windows message}
MyMsg := RegisterWindowMessage('MyApp');
{Set form1's windows proc to ours and remember the old window proc}
OldWindowProc := Pointer(SetWindowLong(Form1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Set form1's window proc back to it's original procedure}
SetWindowLong(Form1.Handle,
GWL_WNDPROC,
LongInt(OldWindowProc));
end;

begin
{Tell Delphi to hide it's hidden application window for now to avoid}
{a "flash" on the taskbar if we halt due to another instance}
 ShowWindow(Application.Handle, SW_HIDE);
end.

[001836]


Как правильно завершить некое приложение?

Nomadic рекомендует следующий код:

Если не принудительно, то можно послать на его Instance сообщение WM_QUIT. Если же необходимо принудительно терминировать приложение, то смотрите ниже - под Windows NT процесс можно терминировать через специально предназначенный для этого хэндл. Иначе гарантии нет. Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда -

var
dwResult: Longint; // This example was converted from C source.
begin                // Not tested. Some 'nil' assignments must be applied
// as zero assignments in Pascal. Some vars need to
// be declared (maxworktime, si, pi). AA.
if CreateProcess(nil, CmdStr, nil, nil, FALSE,
CREATE_NEW_CONSOLE, nil, nil, si, pi) then
begin
CloseHandle( pi.hThread );
dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);
CloseHandle( pi.hProcess );
if dwResult <> WAIT_OBJECT_0 then
begin
pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
if pi.hProcess <> nil then
begin
TerminateProcess(pi.hProcess, 0);
CloseHandle(pi.hProcess);
end;
end;
end;
end;

Панферов Андрей делится следующим кодом (рабочий вариант, Delphi 5):

var
Form1: TForm1;
// Глобальные переменные:
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
StartEn: Boolean = False;

implementation

{$R *.DFM}

// Запуск процесса
 procedure TForm1.StartButtonClick(Sender: TObject);
var
CmdStr: PChar; // Командная строка для запуска приложения
begin
CmdStr := PChar(FilenameEdit1.FileName); // Определение командной строки

StartEn := False; // Запущено ли приложение

// Без этого приложение не стартует =<
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_NORMAL; // Состояние окна запущенного приложения
// <= Без этого приложение не стартует

// Запускаем процесс
StartEn := CreateProcess(nil,
CmdStr,            { указатель командной строки }
nil,               { указатель на процесс атрибутов безопасности }
nil,               { указатель на поток атрибутов безопасности }
False,             { флаг родительского обработчика }
CREATE_NEW_CONSOLE or        { флаг создания }
NORMAL_PRIORITY_CLASS,
nil,               { указатель на новую среду процесса }
nil,               { указатель на имя текущей директории }
StartupInfo,       { указатель на STARTUPINFO }
ProcessInfo);      { указатель на PROCESS_INF }

EndButton.Enabled := StartEn;
end;

// Терминация процесса
procedure TForm1.EndButtonClick(Sender: TObject);
begin
if StartEn then begin
ProcessInfo.hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessInfo.dwProcessId);
if ProcessInfo.hProcess <> Null then begin
TerminateProcess(ProcessInfo.hProcess, 0);
CloseHandle( ProcessInfo.hThread );
CloseHandle( ProcessInfo.hProcess );
end;
end;
StartEn := False;
EndButton.Enabled := StartEn;
end;

[001136]


Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

Nomadic рекомендует следующий код:

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

procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD); stdcall;
begin
//
// Тело процедуры.
 end;

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру

uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

Подробности смотри в Help. Hу и в конце убиваешь таймер

timeKillEvent(uTimerID);

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

Обратите внимание на то, что все CALLBACK-функции, вызываемые Windows, должны использовать соглашение о вызовах stdcall. [001140]


Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp?

Nomadic рекомендует следующий код:

Если только послать, то проще всего, пожалуй...

W32: F1 "NetMessageBufferSend";
Win16: Почему-то неописан, но руками наковырял...

function NetMessageBufferSend(
Zero1, Zero2: Word;
WhoTo: PChar;
Buffer: PChar; BufSize: Word): Integer; external 'NETAPI' index 525;

"Кому" может быть '*' == всем. [001163]


Что нужно давать WSAAsyncSelect в качестве параметра handle, если тот запускается и используется в dll (init), и никакой формы (у которой можно было бы взять этот handle) в этой dll не создается?

Nomadic рекомендует следующий код:

const
WM_ASYNCSELECT = WM_USER+0;

type
TNetConnectionsManager = class(TObject)
protected
FWndHandle : HWND;
procedure WndProc( var MsgRec : TMessage );
...
end;

constructor TNetConnectionsManager.Create
begin
inherited Create;
FWndHandle := AllocateHWnd(WndProc);
...
 end;

destructor TNetConnectionsManager.Destroy;
begin
...
if FWndHandle<>0 then DeallocateHWnd(FWndHandle);
inherited Destroy;
end;

procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage );
begin
with MsgRec do
if Msg = WM_ASYNCSELECT then WMAsyncSelect(MsgRec)
else DefWindowProc( FWndHandle, Msg, wParam, lParam );
end;

Hо pекомендую посмотpеть WinSock2, в котоpом можно:

WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE );
WSAWaitForMultipleEvents( ... );
WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents );

То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios. [001168]


Вызов других программ

VRSLazy@mail.ru пишет:

Доброго времени суток,

Вот посмотрел Ваше произведение Советы по делфи, мне очень понравилось :-)

Правда в вопросе/решении запустить другую программу просто обалдел :-( Я как то долго мучился с этим самым ShellExecute пока не пришёл к следующему:

uses ...ToolWin, Windows ...

procedure Run(App: String);
var ErrStr : String;
PMSI: TStartupInfo;
PMPI: TProcessInformation;
begin
try
CreateProcess(nil, @App[1] , nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, PMSI, PMPI);
except
ErrStr := 'Fault run process: '''+App+'''';
Application.MessageBox(@ErrStr[1],'Failure process',MB_OK+MB_ICONERROR);
end;

разумеется это одно из самых корявых решений, но всё же работает, как вариант сойдет? [001268]


Получение списка запущеных приложений

Igor Nikolaev aKa The Sprite предлагает следующий код:

procedure TForm1.Button1Click(Sender: TObject);
VAR
Wnd : hWnd;
buff: ARRAY [0..127] OF Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd <> 0 DO BEGIN {Hе показываем:}
IF (Wnd <> Application.Handle) AND {-Собственное окно}
IsWindowVisible(Wnd) AND {-Hевидимые окна}
(GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0)
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;

[001412]


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

Nomadic рекомендует следующее:

A: WinExec() или ShellExecute. У второй больше возможностей.

(SO): CreateProcess() в параметре process info возвращает handle запущенного процесса. Вот и делаешь WaitForSingleObject(pi.hProcess, INFINITE);

(AA): (Win16) Delay можно взять из rxLib.

handle := WinExec(...);
if handle >= 32 then
while GetModuleUsage(handle) > 0 do
Delay( nn );
else
raise ....

(AM): Чтобы выяснить, работает ли программа, используйте GetProcessTimes(), параметр lpExitTime.

(Win32) Для принудительного завершения процесса -- TerminateProcess.

(Win16) (RR): Надо послать программе сообщение WM_QUIT:

Handle := Winexec(App, 0);
PostMessage(Handle, WM_QUIT, 0, 0);

[001518]


Открытие выбранного файла в работающем приложении

Пангин Дмитрий Викторович прислал письмо следующего содержания:

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

\\ В файле проекта:
var
i: integer;
hMainForm:hwnd;
copyDataStruct:TCopyDataStruct;
ParamString:string;
WParam,LParam:integer;
begin
\\ ищем главное окно приложения, вместо Caption - nil,
\\ поскольку к заголовку главного окна может добавиться заголовок MDIChild
\\ (нужно позаботиться об уникальности имени класса главной формы)
hMainForm:= FindWindow('TMainForm',nil);
if  hMainForm = 0 then
begin
Application.Initialize;
Application.CreateForm(TFrmMain,frmMain);
for i:=1 to ParamCount do
TMainForm(Application.MainForm).OpenFile(ParamStr(i));
Application.Run;
end
else
begin
ParamString:='';
for i:=1 to ParamCount do
begin
\\ запихиваем все параметры в одну строку с разделителями ?13
ParamString:=ParamString+ParamStr(i)+ #13;
end;
\\ создаем запись типа TCopyDataStruct
CopyDataStruct.lpData:=PChar(ParamString);
CopyDataStruct.cbData:=Length(ParamString);
CopyDataStruct.dwData:=0;
WParam:=Application.Handle;
LParam:=Integer(@CopyDataStruct);
\\ отсылаем сообщение WM_COPYDATA главному окну открытого приложения
SendMessage(hMainForm,WM_CopyData,WParam,LParam);
Application.Terminate;
end;
end.

\\ Обработчик сообщения WM_COPYDATA
procedure TMainForm.CopyData(var Msg: TWMCopyData);
var
ParamStr:string;
CopyDataStructure:TCopyDataStruct;
i:integer;
len:integer;
begin
CopyDataStructure:= Msg.CopyDataStruct^;
ParamStr:='';
len:=  CopyDataStructure.cbData;
for i:=0 to len-1 do
begin
ParamStr:=ParamStr+(PChar(CopyDataStructure.lpData)+i)^;
end;

i:=0;
while not(Length(ParamStr)=0) do
begin
if isDelimiter(#13,ParamStr,i) then
begin
OpenFile(Copy(ParamStr,0,i-1));
ParamStr:=Copy(ParamStr,i+1,Length(ParamStr)-i-1);
end;
inc(i);
end;
inherited;
end;

\\ проверено, работает.

[001532]


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

The_Sprite прислал письмо следующего содержания:

Данная функция позволяет завершить выполнение любой активной программы по её classname или заголовку окна. Совместимость: Все версии Delphi

Исходный код функции

procedure KillProgram(Classname : string; WindowTitle : string);
const
PROCESS_TERMINATE = $0001;
var
ProcessHandle : THandle;
ProcessID: Integer;
TheWindow : HWND;
begin
TheWindow := FindWindow(Classname, WindowTitle);
GetWindowThreadProcessID(TheWindow, @ProcessID);
ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
TerminateProcess(ProcessHandle,4);
end;

Комментарии

Xianguang Li=(22 Октября 2000) В Delphi 5, при компиляции получается следующая ошибка :

  Incompatible types: 'String' and 'PChar'.
После изменения выражения

TheWindow := FindWindow(ClassName, WindowTitle)

на

TheWindow := FindWindow(PChar(ClassName), PChar(WindowTitle)) ,

Нормально откомпилировалось.

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

KillProgram(nil, WindowTitle)

или

KillProgram(ClassName, nil)

Компилятор не позволяет передать nil в переменную типа String.

Итак, я изменил объявление

KillProgram(ClassName: string; WindowTitle: string)

на

KillProgram(ClassName: PChar; WindowTitle: PChar),

вот теперь функция действительно может завершить любое приложение, если вы не знаете ClassName или WindowTitle этого приложения. [001536]


Как перехватывать клавиши, нажатые в окне другой программы? И вообще, любые события, поступающие другим программам?

Nomadic которок:

SetWindowsHookEx() [001549]


Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?

Nomadic отвечает:

Под Windows 95 это возможно с использованием вспомогательных инфоpмационных функций (tool help functions).

Для получения списка пpоцессов надо делать следующее:

  1. Cпеpва вызывается фукция
    hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    // - получение снимка состояния системы

  2. Process32First() - получене инфоpмации о пеpвом пpоцессе в списке

  3. Далее в цикле Process32Next() - получение инфоpмации о следующем пpоцессе в списке
Пример:

>== Режем pаз ==>

unit KernlUtl;

interface
uses TlHelp32, Windows, Classes, Sysutils;

procedure GetProcessList(List: TStrings);
procedure GetModuleList(List: TStrings);
function GetProcessHandle(ProcessID: DWORD): THandle;
procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

const

PROCESS_TERMINATE         =  $0001;
PROCESS_CREATE_THREAD     =  $0002;
PROCESS_VM_OPERATION      =  $0008;
PROCESS_VM_READ           =  $0010;
PROCESS_VM_WRITE          =  $0020;
PROCESS_DUP_HANDLE        =  $0040;
PROCESS_CREATE_PROCESS    =  $0080;
PROCESS_SET_QUOTA         =  $0100;
PROCESS_SET_INFORMATION   =  $0200;
PROCESS_QUERY_INFORMATION =  $0400;
PROCESS_ALL_ACCESS        =
STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;

implementation

procedure GetProcessList(List: TStrings);
var
I: Integer;
hSnapshoot: THandle;
pe32: TProcessEntry32;
begin
List.Clear;
hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

if (hSnapshoot = -1) then
Exit;
pe32.dwSize := SizeOf(TProcessEntry32);
if (Process32First(hSnapshoot, pe32)) then
repeat
I := List.Add(Format('%x, %x: %s',
[pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));
List.Objects[I] := Pointer(pe32.th32ProcessID);
until not Process32Next(hSnapshoot, pe32);

CloseHandle (hSnapshoot);
end;

procedure GetModuleList(List: TStrings);
var
I: Integer;
hSnapshoot: THandle;
me32: TModuleEntry32;
begin
List.Clear;
hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
if (hSnapshoot = -1) then
Exit;
me32.dwSize := SizeOf(TModuleEntry32);
if (Module32First(hSnapshoot, me32)) then
repeat
I := List.Add(me32.szModule);
List.Objects[I] := Pointer(me32.th32ModuleID);
until not Module32Next(hSnapshoot, me32);

CloseHandle (hSnapshoot);
end;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);
var
ProcessID: DWORD;
hSnapshoot: THandle;
pe32: TProcessEntry32;
begin
ProcessID := GetCurrentProcessID;
ID := -1;
Path := '';

hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

if (hSnapshoot = -1) then
Exit;

pe32.dwSize := SizeOf(TProcessEntry32);
if (Process32First(hSnapshoot, pe32)) then
repeat
if pe32.th32ProcessID = ProcessID then
begin
ID := pe32.th32ParentProcessID;
Break;
end;
until not Process32Next(hSnapshoot, pe32);

if ID <> -1 then
begin
if (Process32First(hSnapshoot, pe32)) then
repeat
if pe32.th32ProcessID = ID then
begin
Path := pe32.szExeFile;
Break;
end;
until not Process32Next(hSnapshoot, pe32);
end;
CloseHandle (hSnapshoot);
end;

function GetProcessHandle(ProcessID: DWORD): THandle;
begin
Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;

end.

>== Режем два ==< [001608]


Изменение заголовка `чужого` окна

Nomadic отвечает:

SetWindowText('Текущий заголовок', 'Желаемый');

Например:

Заменить заголовк окна "Блокнот" на "Мой НЕ Блокнот"

SetWindowText('Блокнот','Мой НЕ Блокнот');

[001766]


Как запустить Windows Explorer, открытый на какой-то определенной папке?

Своим опытом делится Олег Кулабухов:

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

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(0,
'explore',
'C:\WINDOWS',
nil,
nil,
SW_SHOWNORMAL);
end;

[001777]


Работа с другим приложением без Hook и DLL на примере GetFocus

Своим опытом делится SottNick:

На стандартной форме (Form1):

Form1.FormStyle=fsStayOnTop - форма поверх остальных окон

Объекты:

  1. ТАЙМЕР (Timer1) с периодом 1000 или меньше,
  2. 3 метки (Label1, Label2, Label3). назначение их см. в тексте процедуры
  3. У таймера событие OnTimer. а вот для нее обработчик:
procedure TForm1.Timer1Timer(Sender: TObject);
var
dwTargetOwner :DWORD;//указатель на подключаемый процесс
dwThreadID :DWORD;//указатель на текущий процесс
Result:longbool;
begin
{В первой метке отображается Handle активного окна}
Label1.Caption:=IntToStr(GetForegroundWindow);//указатель на подключаемое приложение

// Подключение потока другого окна
dwTargetOwner := GetWindowThreadProcessId(GetForegroundWindow,nil);//указатель на подключаемый процесс
dwThreadID := GetCurrentThreadId();//указатель на текущий процесс
if (dwTargetOwner <>dwThreadID) then // если не один и тот же процесс
Result := AttachThreadInput(dwThreadID, dwTargetOwner, TRUE);//подключение

{Во второй метке отображается Handle объекта 'в фокусе' в активном окне}
Label2.Caption:=IntToStr(GetFocus);//фокус в другом приложении

if (Result) then
AttachThreadInput(dwThreadID, dwTargetOwner, FALSE);//отключение

{В третей метке отображается Handle объекта 'в фокусе' в активном окне,
но если это окно другого приложения, то Handle будет равен нулю,
т.к. попытка получения Handle происходит после отключения потока}
Label3.Caption:=inttostr(GetFocus);//проверка после отключения

{Эффект можно посмотреть, если запустить полученное приложение
и сделать активным другое приложение}
{Ясно, что полученный Handle объекта можно использовать
по своему разумению. Например, считать из объекта текст и т.п.}

// (C) SottNick 2000
 end;

[001801]


Как создать мигающую иконку (свернутое окно)?

Своим опытом делится Олег Кулабухов:

Используйте FlashWindow().

var
Flash : bool;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Form1.Handle, Flash);
FlashWindow(Application.Handle, Flash);
Flash := not Flash;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Flash := False;
end;

[001820]


Можно ли программно закрыть какое-либо приложение?

Своим опытом делится Олег Кулабухов:

Да, нужно просто послать сообщение WM_QUIT его окну.

PostMessage(FindWindow(Nil, 'window caption'), WM_QUIT, 0, 0);

'window caption' - заголовок окна, которое нужно закрыть. [001830]


Можно ли заблокировать обновление определенного окна?

Своим опытом делится Олег Кулабухов:

LockWindowUpdate(Memo1.Handle);
.
.
 LockWindowUpdate(0);

[001835]


Как поменять приоритет моего приложения?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject);
var
ProcessID : DWORD;
ProcessHandle : THandle;
ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
false,
ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

[001851]


Как можно гарантированно очистить экран в консольном приложении?

Своим опытом делится Олег Кулабухов:

Нужно просто использовать GetConsoleScreenBufferInfo() для ввода нескольких пустых строк.

program Project1;

{$APPTYPE CONSOLE}

uses
Windows;

{$R *.RES}

var
sbi : TConsoleScreenBufferInfo;
i : integer;
begin
Writeln('A Console Applicaiton');
Writeln('Press Enter To Clear The Screen');
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
Readln;
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
for i := 0 to sbi.dwSize.y do
writeln;
Writeln('Press Enter To End');
Readln;
end.

[001855]


Проблема циклических ссылок

У меня имеется объект A и объект B, и им обоим нужно вызывать методы друг друга...

Объявите абстрактный базовый класс, определяющий интерфейс класса для того, чтобы другие классы могли его видеть. Используйте виртуальные абстрактные методы и свойства. Затем объявите другие классы подклассами базового класса (при необходимости). Данный метод существенно поможет в структурировании вашего приложения.

- Mike Scott. [001135]


Delphi 1

Создание множества экземпляров

list:=Tlist.create; For i:= 1 to 1000 do
begin
SSObject:=TSSObject.create;
{поместите куда-нибудь ссылку на созданный объект - например, в Tlist}
list.add(SSObject);
end;

[001184]


Delphi 1

Передача функции как параметра

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

type
TMyFuncType = function : integer ;

var
MyFunc : TMyFuncType ;

function foo: integer;
begin
result := 1;
end;

begin
MyFunc := foo ;
DllFunction( longint( MyFunc )) ;

Вы можете это сделать и так:

DllFunction( longint( @foo )) ;

Все же я не уверен в вопросах корректности использования таким образом в вызовах DLL. памяти (для меня пока неясна работа с памятью, находящейся в другом сегменте), как в этом примере, так что возможно для корректной работы вам придется объявить foo с директивой far, экспортировать ее в модуле, или что-то еще.

Также, в зависимости от того, как написана DllFunction(), вы можете в вызове подразумевать приведение типа:

function DllFunction( p: TMyFuncType ): Integer;
far; external 'mydll';

В этом случае вам не нужна будет переменная MyFunc или оператор @.

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

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);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

type
IntFunc = function: integer;

function DllFunction(iFunc: IntFunc): integer; far;
begin
DllFunction := iFunc; {Обратите внимание на то, что это вызов функции}
end;

function iFoo: integer; far;
begin
iFoo := 1;
end;

procedure TestIFunc;
var
i: integer;
begin
i := DllFunction(iFoo);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
TestIFunc;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;

end.

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

i := longint(@foo)

Другая вещь, которую вы можете сделать - исключить работу с longint и вызывать функцию dll следующим образом:

DLLfunction (@foo);

Имейте в виду, что если вы собираетесь вызывать foo из DLL, то необходимо предусмотреть вопросы совместимости, для получения дополнительной информации почитайте описание функции MakeProcInstance. [001196]


Delphi 1

Проблема передачи записи

Может это не то, что вы ищете, но идея такая:

Определите базовый класс с именем, скажем, allrecs:

tAllrecs = class
function getVal (field: integer): string; virtual;
end;

Затем создаем классы для каждой записи:

recA = class (tAllrecs)
this      : Integer;
that      : String;
the_other : Integer;
function getVal (field: integer): string; virtual;
end;

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

function recA.getVal (field: integer); string;
begin
case field of
1: getVal := intToStr (this);
2: getVal := that;
3: getVal := intToStr (the_other);
end;
end;

Затем вы можете определить

function myFunc (rec: tAllrecs; field: integer);
begin
label2.caption := allrecs.getVal(field);
end;

затем вы можете вызвать myFunc с любым классом, производным от tAllrecs, например:

myFunc (recA, 2);
myFunc (recB, 29);

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

Все это работает, т.к. данный пример я взял из моего рабочего проекта.

[Sid Gudes, cougar@roadrunner.com]

Если вы хотите за один раз передавать целую запись, установите на входе ваших функций/процедур тип 'array of const' (убедитесь в правильном приведенни типов). Это идентично 'array of TVarRec'. Для получения дополнительной информации о системных константах, определяемых для TVarRec, смотри электронную справку по Delphi. [001198]


Delphi 1

Указатель на функцию I

Это то, что я нашел при создании простой машины состояний:

Ниже приведен простой пример для Borland Delphi, использующий указатели функций для управления программным потоком. Просто создайте простую форму с единственной кнопкой и скопируйте код из Unit1 во вновь созданный модуль. Добавьте к проекту Unit2 и скомпилируйте проект. Дайте мне знать, если у вас возникнут какие-либо проблемы.

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;
CurrProc : LongInt;
MyVal : LongInt;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
NewProc : LongInt;
MyString : string;
begin
CurrProc := 2;                { начальная точка в таблице методов }
MyVal := 0;                   { вспомогательная переменная }
NewProc := 0;                 { возвращаемое значение для следующего индекса в таблице методов }
while CurrProc < 6 do
begin
{ выполняем текущий индекс в таблице методов и получаем следующую процедуру }
NewProc := ProcTable[CurrProc](MyVal);

{ просто показываем значения NewProc и CurrProc }
FmtStr(MyString, 'NewProc [%d] CurrProc [%d]', [NewProc, CurrProc]);
MessageDlg(MyString, mtInformation, [mbOK], 0);

{ присваиваем текущую процедуру возвращаемой процедуре }
CurrProc := NewProc;
end;

end;

end.

{ Это простой пример, определяющий массив указателей на функции }

interface

type
{ определяем Procs как функцию }
Procs = function(var ProcNum : LongInt): LongInt;

var
{ объявляем массив указателей на функции }
ProcTable : Array [1..5] of Procs;

{ определения интерфейсов функций }
function Proc1(var MyVal : LongInt) : LongInt; far;
function Proc2(var MyVal : LongInt) : LongInt; far;
function Proc3(var MyVal : LongInt) : LongInt; far;
function Proc4(var MyVal : LongInt) : LongInt; far;
function Proc5(var MyVal : LongInt) : LongInt; far;

implementation

uses Dialogs;

function Proc1(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 1', mtInformation, [mbOK], 0);
Proc1 := 6;
end;

function Proc2(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 2', mtInformation, [mbOK], 0);
Proc2 := 3;
end;

function Proc3(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 3', mtInformation, [mbOK], 0);
Proc3 := 4;
end;

function Proc4(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 4', mtInformation, [mbOK], 0);
Proc4 := 5;
end;

function Proc5(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 5', mtInformation, [mbOK], 0);
Proc5 := 1;
end;

initialization

{ инициализируем содержание массива указателей на функции }
@ProcTable[1] := @Proc1;
@ProcTable[2] := @Proc2;
@ProcTable[3] := @Proc3;
@ProcTable[4] := @Proc4;
@ProcTable[5] := @Proc5;

end.

Я думаю это можно сделать приблизительно так: объявите в каждой форме процедуры, обрабатывающие нажатие кнопки, типа процедуры CutButtonPressed(Sender:TObject) of Object; затем просто назначьте события кнопок OnClick этим процедурам при наступлении событий форм OnActivate. Этот способ соответствует концепции ОО-программирования, но если вам не нравится это, то вы все еще можете воспользоваться указателями функций, которая предоставляет Delphi.

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

Пример: (Здесь может встретиться пара синтаксических ошибок - я не компилил это)

type
TBaseForm = class(TForm)
public
procedure Method1; virtual; abstract;
end;

type
TDerivedForm1= class(TBaseForm)
public
procedure Method1; override;
end;

TDerivedForm2= class(TBaseForm)
public
procedure Method1; override;
end;

procedure TDerivedForm1.Method1;
begin
....
end;

procedure TDerivedForm2.Method1;
begin
....
end;

{Для вызова функции из вашего toolbar, получите активную в настоящий момент форму и вызовите Method1}
 procedure OnButtonClick;
var
AForm: TBaseForm;
begin
AForm := ActiveForm as TBaseForm;
AForm.Method1;
end

[001190]


Delphi 1

Указатель на функцию II

Что лично я использую, чтобы вызвать какую-то функцию из DLL:

  1. Объявите тип:

    type
    TYourDLLFunc = function(Parm1: TParm1; Parm2: TParm2): TParm3;

  2. Объявите переменную этого типа:

    var
    YourDllFunc: TYourDLLFunc;

  3. Получаем дескриптор DLL:

    DLLHandle := LoadLibrary('YourDLL.DLL');

  4. Получаем адрес функции:

    @YourDLLFunc := GetProcAddress(DLLHandle, 'YourDLLFuncName');

  5. Для использования функции теперь используйте переменную YourDLLFunc, например:

    Parm3 := YourDLLFunc(Parm1, Parm2);

[001199]


Delphi 1

Использование указателей на целое

Сначала вы должны создать тип:

Type
Pinteger : ^Integer;

Var
MyPtr : Pinteger;

Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.

Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.

Например,

NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr)).

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

Для полноты, это должно быть:

NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));

SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.

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

Type
pIntArr = ^IntArr;
IntArr  = Array[1..1000] of Integer;
Var
MyPtr : pIntArr;
Begin
GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!)
{ MyPtr[2]:=1; }
 <<<< Заполняем массив >>>>
MyPtr[2]^:=1;

FreeMem(MyPtr,10);
End;

Технология похожа на ту, которуя Delphi использует при работе с pchar. Синтаксис очень похож:

type
intarray = array[0..20000] of integer;

procedure TForm1.Button1Click(Sender: TObject);
var
xptr:  ^IntArray;
begin
GetMem(xptr, 10);
xptr^[idx] := 1;  { где idx от 0 до 4, поскольку мы имеем 10 байте = 5 целых }
FreeMem(xptr, 10);
end;

Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!) [001205]


Delphi 2

Функция MemAvail для Delphi2?

В Delphi 1, для того, чтобы получить самый большой возможный участок памяти, мы могли использовать функцию MemAvail, существует ли эквивалент этой функции в Delphi 2?

Нет. Но чтобы получить аппроксимированную сумму доступной памяти, можно воспользоваться функцией API GlobalMemoryStatus (через поле dwAvailVirtual возвращаемой структуры TMemoryStatus).

-Steve Schafer [001119]


Как работать с блоками памяти размером более 64K?

Nomadic советует:

Так можно помещать в один блок памяти записи из TList (TCollection):

imlementation
{ To use the value of AHIncr, use Ofs(AHIncr). }
procedure AHIncr; far; external 'KERNEL' index 114;

const
NEXT_SELECTOR: string[13] = 'NEXT_SELECTOR';

function WriteData: THandle;
var
DataPtr: PChar;
i: Integer;
begin
Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, {pазмеp большого блока});
if Result = 0 then Exit;

DataPtr := GlobalLock(Result);

{записываем кол-во эл-тов}
Inc(DataPtr, {pазмеp счетчика эл-тов})

for i := 0 to {некий}Count-1 do
begin
if LongInt(PtrRec(DataPtr).Ofs) + {pазмеp подблока} >l= $FFFF then
begin
Move(NEXT_SELECTOR, DataPtr^, SizeOf(NEXT_SELECTOR)); {некая константа}
{ коppекция сегмента }
PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);
PtrRec(DataPtr).Ofs := $0;
end;
Inc(DataPtr, {pазмеp нового блока});
end; { for i }
GlobalUnlock(Result);
end;

procedure ReadData(DataHdl: THandle);
var
DataPtr : PObjectCfgRec;
RecsCount: Integer;
i: Integer;
begin
if DataHdl = 0 then Exit;
DataPtr := GlobalLock(DataHdl);
RecsCount := PInteger(DataPtr)^;
Inc(PInteger(DataPtr));
for i := 1 to RecsCount do
begin
{ обpаботать данные }
Inc(DataPtr);
if PString(DataPtr)^ = NEXT_SELECTOR then
begin
PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);
PtrRec(DataPtr).Ofs := $0;
end;
end; { for i }
GlobalUnlock(DataHdl);
end;

[001222]


Delphi 1

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

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

theMenuitem.OnClick := TheOnClickHandler;

Затем, в обработчике OnClick, вы приводите sender к TMenuItem и читаете имя:

procedure theform.TheOnClickHandler(Sender: TObject);
var
fName: String;
begin
fName := TMenuItem(Sender).name;
...
end;

[001460]


Delphi 1

События для компонентов, созданных во время работы программы I

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

Пример:

TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FMyButton: TButton;
protected
procedure Button1Click(Sender: TObject); {Кодируем это вручную,
для соответствия}
{структуре
TNotifyEvent}
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FMyButton := TButton.Create;
{Здесь устанавливаем позицию, заголовок и все остальное}
FMyButton.OnClick := MyButtonClick;
end;

procedure TForm1.MyButtonClick(Sender: TObject);
begin
ShowMessage('Эй! Ты нажал на мою кнопку!');
end;

[001513]


Delphi 1

События для компонентов, созданных во время работы программы II

Вот простейший код для нового проекта с одной кнопкой и меню. (Надеюсь, в этом ничего сложного нет ... :)

{Процедура создания нового пункта меню ...}
procedure TForm1.Button1Click(Sender: TObject);
var
NewItem: TMenuItem;
begin
NewItem := TMenuItem.Create(Form1);
NewItem.Caption := 'Динамический элемент ...';
NewItem.OnClick := xyz;
MainMenu1.Items.Insert(0, NewItem);     <- Примечание: рекомендую бегло ознакомиться
end;                                               с Delphi-примером для команды Insert ...
{Любая старая 'xyz'-процедура (в настоящее время может быть определена одна,
например, Form1.DblClick)}
 procedure TForm1.xyz(Sender: TObject);
begin
showmessage('Запусти эту процедуру !!');
end;

Примечание: Если вы пользуетесь неопределенной процедурой, вам понадобиться объявить ее. Лично я все это сделал в "верхнем правом углу" объявления типа формы, примерно так:

private
{ Private declarations }
public
{ Public declarations }
procedure xyz(Sender: TObject);   <- К этой процедуре могут иметь доступ
не только события Form1 ...

Установите свойство обработчика события (например, OnClick, OnDblClick, OnMouseDown и пр.) на процедуру, которую вы создали для обработки этого события. Вам нужно убедиться в том, что параметры в точности соответствуют параметрам ожидаемого заданного обработчика события.

Например:

MySpeedButton.OnClick := MyClickEventHandler;

где...

procedure MyClickEventHandler(Sender: TObject);
begin

end;

[001515]


Delphi 1

Процедура OnClose

Мой опыт показывает, что OnClose возникает только при вызове Close. Тем не менее, OnDestroy всегда вызывается в случае освобождения (Free) или разрушения (Destroy) формы. Я помещал свой Table.Post в обработчик OnClose, но это не всегда вызывалось. Попробуйте поместить MessageBeep в обработчик OnClose, или найти какой-то другой способ выяснить когда точно ваш код будет вызван.

Я запускал тест, который предлагал выполнить Application.Terminate в обработчике события формы Destroy, а НЕ событий OnClose или OnCloseQuery, в отличие от VB.

Я так понимаю, что Task Manager в действительности не закрывает приложение. Он просто сообщает приложению о необходимости его закрытия посредством посылки ему соответствующего сообщения. Также, я надеюсь, что главное окно приложения, которое Delphi назначает вашему приложению, проходит по списку своих дочерних компонентов, которые оно имеет, и сообщает им об инициализации закрытия приложения. Но все это нуждается в тестировании, начиная от программного способа через Delphi, и заканчивая закрытием задачи через Task Manager. Сделайте это несколько раз, при этом поглядывая на счетчик ресурсов.
[001570]


Delphi 1

Проблема горячих клавиш и OnKeyDown

Я обнаружил, что между onKeyPress и onKeyDown существует какое-то странное взаимодействие; установка key в 0 в onKeyDown не обязательно убивает это в onKeyPress.

...очевидно, вы делаете все это в обработчике onKeyDown; если вы сделаете это в onKeyPress и установите значение key, равным 0, системные сигналы должны пропасть. Кроме того, вы можете сделать так:

в onKeyDown:

killKey := false;
If key = $4f then begin
killKey := true;
bitBtn1Click (bitBtn1);
end;

в onKeyPress:

if killKey then key := #0;

[001573]


Delphi 1

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

Это просто красиво: вы определяете процедуру (скажем, ThisOne), которая получает тот же список параметров, что и onTimer, после чего, в нужный момент, вы связываете ее с таймером, просто записывая:

Timer1.onTimer := ThisOne;

Чтобы выключить обработку события, сделайте:

Timer1.onTimer := nil;

Процедура (ThisOne) не должна принадлежать тому же классу, что и таймер, но она _должна_ получать те же самые параметры в той же самой последовательнойсти, что и родной метод обработки события, а иначе будет "ремонт не по гарантии".

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

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

Я думаю, вы догадались, как должна выглядеть строка кода:

Timer1.ontimerevent:=formdynamictimerevent;

[001590]


Delphi 1

Перехват OnEnter в моем компоненте

Компоненты, имеющие возможность принимать фокус, уже имеют унаследованные методы с именами DoEnter и DoExit.

Procedure DoExit; override;
Procedure DOEnter; override;

procedure MyClassName.DoExit;
begin
fIsFocused := FALSE;
inherited DoExit;
end;

procedure MyClassName.DoEnter;
begin
inherited DoEnter;
fIsFocused := TRUE;
end;

[001627]


Delphi 1

Перехват событий дочерних MDI-форм

procedure TMainForm.FormCreate(Sender: TObject);
begin
{  здесь разместите код FormCreate  }
Screen.OnActiveFormChange := UpdateObjectss;
{  и здесь тоже, если нужно...  }
end;

procedure TMainForm.UpdateObjects(Sender: TObject);
begin
<имяобъекта>.Enabled := MDIChildCount > 0;
end;

(MDIChildCount > 0) возвращает true, если открыто _любое_ дочернее окно, и false в противном случае. Так, вы не должны беспокоиться о количестве открытых дочерних окон. [001789]


Динамические массивы V

SottNick пишет:

Если хочется, чтобы в многомерном массиве был разный размер у разных измерений например: VarArray: array[1..2, 1..?] of TType , где ? зависит от "строки" массива (1..2)

То дозволяется сделать так:

  1. Объявление

    Var
    VarArray: array of array of array............

  2. Установка длин

    SetLength (VarArray, Razmernost1); // У первого измерения

    SetLength (VarArray[1], Razmernost2); // У второго измерения первой "строки"
    SetLength (VarArray[2], Razmernost3); // У второго измерения второй "строки"
    SetLength (VarArray[n], Razmernost4); // У второго измерения n-ной "строки"

    SetLength (VarArray[1][1], Razmernost5); // У третьего измерения первой "строки" первого "столбца"
    SetLength (VarArray[1][2], Razmernost6); // У третьего измерения первой "строки" второго "столбца"
    SetLength (VarArray[n][m], Razmernost7); // У третьего измерения n-ной "строки" m-ного "столбца"

    т.д.
    Все можно изменять в процессе естественно.

  3. Получение длин

    Razmernost1:=Length (VarArray); // У первого измерения (количество строк)

    Razmernost2:=Length (VarArray[1]); // У второго измерения первой "строки" (количество столбцов)
    Razmernost3:=Length (VarArray[2]); // У второго измерения второй "строки" (количество столбцов)
    Razmernost4:=Length (VarArray[n]); // У второго измерения n-ной "строки" (количество столбцов)

    Razmernost5:=Length (VarArray[1][1]); // У третьего измерения первой "строки" первого "столбца"
    Razmernost6:=Length (VarArray[1][2]); // У третьего измерения первой "строки" второго "столбца"
    Razmernost7:=Length (VarArray[n][m]); // У третьего измерения n-ной "строки" m-ного "столбца"

  4. Обращение
    VarArray[n][m][o][p][r]:=1;    // :Integer   // К элементу n-ной "строки",
m-ного "столбца",
                                                           // o-того "?",
p-того "?", r-того "?"
  5. Обнуление (освобождение памяти)

    SetLength (VarArray, 0); // Всех сразу

[001043]


Delphi 1

Динамические массивы VI

Например, если вам необходимо сохранить "GIZMOS" в вашем массиве, сделайте следующее:

CONST
MaxGIZMOS = $FFFF Div (SizeOf(GIZMOS)) { или что-то другое, смотря какой максимальный размер GIZMOS вы планируете...}

TYPE
pGIZMOArray = ^GIZMOArray;
GIZMOArray  = Array[1..MaxGIZMOS] of GIZMOS;

VAR
TheGIZMOS: pGIZMOArray;
GIZMOcount: integer;
BEGIN
GetMem(TheGIZMOS,(GIZMOcount+1)*SizeOf(GIZMO)); {Нужна дополнительная единица, поскольку массив GetMem ведет отсчет с нуля...}
TheGIZMOS^[index] := Whatever;
ну и так далее...

TList - такой динамический массив. Для получения дополнительной информации обратитесь к электронной справке. Если вы хотите это делать сами, то вам необходимо использовать GetMem для получения указателя на распределенную динамическую память, и затем FreeMem для освобождения памяти, занятой динамическим массивом. Tlist сделает это за вас самым надежным образом. [001180]


Delphi 1

Динамические массивы VII

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

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

  2. Если вам необходим динамический многомерный массив строк, вы также можете воспользоваться tStringList (в случае, если число элементов вашего массива не превышает лимит для tStringList, я полагаю он равен 16,000). Чтобы сделать это, создайте функцию линейного распределения как показано ниже:

    Допустим у вас есть трехмерный массив строк, текущее измерение [12,80,7], и вы хотите найти элемент [n,m,x]. Вы можете найти этот элемент в приведенном одномерном массиве с помощью формулы ((n-1)*80*7 + (m-1)*80 + x). Затем вы можете использовать это в качестве индекса в tStringList. Для диманического изменения одной из границ массива, используйте метод tStringList Move, служащий как раз для таких целей. (Метод состоит из некоторых технологических внутренних циклов, но выполняются они очень быстро, поскольку tStringList манипулирует не с самими строками, а с указателями на них.)

  3. Если вам необходим динамический одномерный массив чисел, то в общих словах я приведу его ниже, но есть масса мелких деталей. Объявите указатель на тип массива, имеющего максимальное количество элементов данного типа (помните о том, что Delphi-16 позволяет иметь типам область памяти, ограниченной 64K), например так:

    type
    bigArray: array[1..32000] of integer;  {или ^double, или что-то еще}
    pMyArray: ^bigArray;

    затем распределите сам массив:

    getMem (pMyArray, sizeof(integer) * n);

    , где n - количество элементов. После этого вы можете ссылаться на элементы массива следующим образом:

    pMyArray^[51]

    Не забудьте освободить массив с помощью FreeMem после того, как вы его использовали.

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

    pTemp: ^bigArray;

    getMem (pTemp, sizeof(integer) * newnumelements);
    memcopy (pTemp, pMyArray, sizeof(integer)*n);
    {n - количество элементов в pMyArray}
    freeMem (pMyArray, sizeof(integer)*n);
    pMyArray := pTemp;

  4. Если вам необходим многомерный массив чисел, скомбинируйте технику, описанную в пункте (3), с функцией распределения, описанной в пункте (2).

  5. Если для вашего массива необходим участок памяти больше чем 64K, вам необходимо разработать список указателей на участки памяти, но эта тема выходит за рамки данной статьи.

Лично я инкапсулировал все в своем объекте. Я использую, как я это называю, "Basic String Object" (BSO), базовый строковый объект, который осуществляет динамическое распределение и освобождение памяти для строк любого размера. Непосредственно это PChar, указывающий на распределенную память. У меня существует два внешних свойства: AsString и AsPChar. Также у меня есть различные свойства и методы, позволяющие иметь различные способы доступа и манипулировать строками.

Я написал свои собственные malloc(), calloc() и realloc(), используя частные методы объекта TString для сканирования распределенной памяти. Это классно работает, когда мне нужно "захватить" блок памяти.

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

О другой идее я уже рассказывал (открытый массив). Если вам нужна проверка выхода за границы и/или динамическое изменение размера массива, вы можете использовать метод, аналогичный методу работы со строковым объектом (описанный мною выше), но вам необходимо будет интегрировать свойство-массив по умолчанию, чтобы иметь к нему простой доступ. Это позволит вам иметь индексы и использовать нужный вам тип.

TMyDynamicObject =
...
PROPERTY Array[ idx :LONGINT ]:TMyType READ GetArray WRITE PutArray DEFAULT;
...

VAR Mine :TMyDynamicObject;
...
Mine := TMyDynamicObject.Create;
FOR i := 10 TO 20 DO Mine[i] := {значение}

{ЧУДОВИЩНАЯ РАСТРАТА ПАМЯТИ - если вы действительно используете такие большие массивы и хэш-таблицы }
Mine[-100000] := {значение}
Mine[+100000] := {значение}

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

Для того, чтобы хранить все, что вы хотите, вы можете использовать TList (или TStringList.Objects)! TList.Items хранят указатели на объекты или записи, но они ничего не могут сделать с ними, поэтому вы можете привести их к типу longint, и больше о них не беспокоиться! Вот пример хранения в TList списка целых:

var
aList: TList;
I : Integer;
L : Longint;
begin
aList := TList.Create;
L := 93823;
aList.Add(Pointer(L));
aList.Add(Pointer(83293));
for I := 1 to aList.Count do
L := L + Longint(aList.Items[I-1]);
aList.Free;
end;

В TList и TStringList вы можете иметь до 16380 элементов. А теперь обещанный пример того, как можно хранить в TList записи (или объекты), вернее, указатели на них:

type
PMyRec = TMyRec;
TMyRec = record
Name: string[40];
Addr : string[25];
Comments: string;
salary: Double;
end;
var
aList: TList;
aRecPtr: PMyRec;
I : Integer;
begin
aList := TList.Create;
New(aRecPtr);
with aRecPtr^ do
begin
Name := 'Валентин';
Addr := 'неизвестен';
Comments := 'Автор Советов по Delphi';
Salary := 999000.00;
end;
aList.Add(aRecPtr);
aList.Add(... );
...
for I := 1 to aList.Count do
begin
aRecPtr := PMyRec(aList.Items[I-1]);
{что-то делаем с записью}
end;

{теперь избавляемся от всех записей и самого списка-объекта}
for I := 1 to aList.Count do
Dispose(PMyRec(aList.Items[I-1]));
aList.Free;
end;

[001200]


Динамические массивы VIII

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

var
intArray : array of integer;

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

begin
intArray:=(New(IntArray,100); //Размер массива? 100
end;

Igor Nikolaev aKa The Sprite [001416]


Delphi 1

Пример массива констант (Array of Const) III

procedure foo(a : array of const);
implementation
var
var1      : longint;
var2      : pointer;
var3      : integer;
begin
var1 := 12345678;
var2 := @var1;
var3 := 1234;
foo([var1, var2, var3]);

В действительности, массив array of const более корректным было бы назвать массивом array of tvariant. Tvariant - множественный выбор типов переменной, в которой можно задать номер типа. В Visual Basic у него имеется наследник. Delphi также позволяет использовать имена.

Определите тип, например, так:

TYPE
NAME1 = Array[1..4,1..10] of Integer;

Затем, в вашей секции CONST:

NAME2 : NAME1 = ((1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10));

[001171]


Delphi 1

Массив объектов-изображений

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

type
TForm1 = class(TForm)
...
public
images: array [1..10] of TImage;
...
end;

procedure TForm1.FormCreate(...);
var i: integer;
begin
...
for i := 1 to 10 do begin
images[i] := TImage.Create(self);
with images[i] do begin
parent := self;
tag := i; { это облегчит идентификацию изображения }
... установите другие необходимые свойства, например:
OnClick := MyClickEventHndlr;
end;
end;
...
end;

Для того, чтобы убедиться, что все модули в секции "uses" установлены правильно, бросьте на форму один такой динамический компонент, и затем удалите его, или установите его видимость в False. Более сложный способ заключается в разработке собственного компонента, делающего описанное выше. [001173]


Delphi 1

Массив TPOINT

Const
ptarr : Array[0..4] Of TPoint =
((x:0; y:4),
.
.
(x:4; y:4));

[001175]


Delphi 1

Создание больших массивов

В 16-битной версии Delphi нельзя сделать это непосредственно. В новой, 32-битной версии, это как-то можно сделать, но за два месяца колупания я так и не понял как. (Некоторые бета-тестеры знают как. Не могли бы они сообщить нам всю подноготную этого дела?)

В 16-битной версии Delphi вам необходимо работать с блоками по 32K или 64K и картой. Вы могли бы сделать приблизительно следующее:

type
chunk:     array[0..32767] of byte;
pchunk:    ^chunk;
var
BigArray:  array[0..31] of pChunk;

Для создания массива:

for i := 0 to high(bigArray) do
new (bigArray[i]);

Для получения доступа к n-ному байту в пределах массива (n должен иметь тип longint):

bigArray[n shr 15]^[n and $7FFF] := y;
x := bigArray[n shr 15]^[n and $7fff];

Это даже осуществляет проверку выхода за границы диапазона, если вы установили в ваших настройках опцию "range checking"!

n должен находиться в диапазоне [0..32*32*1024] = [0..1024*1024] = [0..1048576].

Для освобождения массива после его использования необходимо сделать следующее:

for i := 0 to high(bigArray) do
dispose (bigArray[i]);

[001182]


Редактор свойств для точки

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

  GetValue/SetValue            для строк (strings)
  GetFloatValue/SetFloatValue  для натуральных чисел (floats)
  GetOrdValue/SetOrdValue      для порядковых (и указателей)
Решением может быть создание класса TPersistentPoint, являющегося наследником TPersistent и имеющего те же свойства, что и TPoint. Вы можете просто "обернуть" TPoint для хранения значений, или создать явные поля. Непосредственное использование TPoint сделает использование метода Assign легким и быстрым для кодирования. Для процедур чтения и записи вы можете использовать поля записи, как показано ниже:

type
TPersistentPoint = class( TPersistent )
private
FPoint : TPoint ;
published
property X : integer read FPoint.X write FPoint.X ;
property Y : integer read FPoint.Y write FPoint.Y ;
end ;

- Mike Scott [001042]


Хитрость вызова редактора свойств

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

Сделайте ваш редактор свойства наследником TStringListProperty (добавьте STREDIT в список используемых модулей) и согласно вашим обстоятельствам вызывайте метод предка Edit:

Unit MyEditor;

interface

uses STREDIT;

type
TMyStringListProperty = class(TStringListProperty)
procedure Edit; override;
end;

implementation

procedure TMyStringListProperty.Edit;
begin
if { какие-то условия } then
{ что-то делаем }
else
inherited Edit;
end;
end.

- Pat Ritchey [001040]


Как убрать публичное свойство компонента/формы из списка видимых/редактируемых свойств в Инспекторе Обьектов?

Nomadic советует:

Из TForm property не убиpал, но из TWinControl было дело. А дело было так :

interface

type

TMyComp = class(TWinControl)
...
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('MyPage', [TMyComp]);
RegisterPropertyEditor(TypeInfo(String),TMyComp,'Hint',nil);
end;

[ и т.д.]

Тепеpь property 'Hint' в Object Inspector не видно. Рад, если чем-то помог. Если будут глюки, умоляю сообщить. Такой подход у меня сплошь и pядом. [001118]


Свойство FileName в невизуальном компоненте

Следующий код взят из dsgnintf.pas (иногда стоит покопаться в файлах!) для свойства TMPLayer.filename, с помощью C.Calvert..

В заголовке модуля компонента...

TFileNameProperty = class (TStringProperty)
public
function getattributes: TPropertyattributes; override;
procedure Edit; override;
end;

добавьте функцию регистрации...

RegisterPropertyEditor(Typeinfo(String),
TMyComponent, 'Filename', TFileNameProperty);

и код...

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

Procedure TFilenameProperty.edit;
var
MFileOpen: TOpenDialog;
begin
MFileOpen := TOpenDialog.Create(Application);
MFileOpen.Filename := GetValue;
MFileOpen.Filter := 'Правильный тип файлов|*.*'; (* Поместите здесь ваш собственный фильтр...*)
MFileOpen.Options := MFileOpen.Options + [ofPathMustExist,ofFileMustExist];
try
if MFileOpen.Execute then SetValue(MFileOpen.Filename);
finally
MFileOpen.Free;
end;
end;

[001519]


Delphi 1

Имя свойства в течение выполнения программы

If ( Sender is TLabel ) then..

или, если вам заранее известен тип объекта, то можно так:

TLabel( Sender ).Caption

Чтобы получить доступ к имени, воспользуйтесь одним из приведенных ниже примеров. Пример:

formname:=(myform as tobject).name;

или

formname:=(myform as tcontrol).name;

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

Если вы используете свойство ClassName подобно этому:

with Sender as TForm do
Label1.Caption := copy(ClassName,2,length(ClassName)-1);

Это даст желаемый эффект без дополнительного кодирования в обработчике формы OnCreate.

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

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

If Sender is TForm then
Label1.Caption := (Sender as TForm).Name ;

Это в случае, если вы пытаетесь выполнить следующее:

Label1.Caption := Form1.Name ;

Это целый сонм проблем. Я читал, что при исполнении этого кода или не доступно свойство Form (во время выполнения программы), или, что чаще, возникает заблуждение относительно инициализируемого класса (вернее, его имени, Form1). Если вы тщательно читали документацию по Delphi, то наверняка заметили тот факт, что установка свойства в Инспекторе Объектов (Object Inspector) НЕ означает его автоматическую установку во время выполнения программы. Чтобы с честью выбраться из этой ситуации, необходимо явно установить свойство (в нашем случае свойство .Name) в методе фомы .Create. Это может выглядеть приблизительно так:

procedure TForm1.Create( Sender : TObject ) ;
begin
Form1.Name := 'Form1' ;
end ;

procedure TForm1.Button1Click( Sender : TObject ) ;
begin
Label1.Caption := Form1.Name ;
end ;

var
TC: TComponent;
begin
TC := label1.Owner;
label1.Caption := TC.ClassName;
end;

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

name := 'AName';

Затем, после щелчка на кнопке, я мог бы щелкнуть на форме, и заголовок метки изменился бы на 'AName'. Решением может служить определение свойcтва Name в обработчике события создания формы. Т.е., если вы назвали форму именем MyForm, то в обработчике события OnCreate вы должны написать следующее:

name := 'MyForm';

Это решит вашу проблему, а я закругляюсь. [001568]


Публикование свойств-наборов

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

myClass = class(TComponent)
private { !! вы пропустили эту директиву защиты }
fMySetProperty : myset;
published
MySetProperty : myset read fMySetProperty write fMySetProperty;
end;

[001575]


Delphi 1

Проверка на существование свойства

{Вероятно, вы захотите заменить "is TButton.." на что-то другое, что вы определили в родителе.. напишите просто if Components[i] in myset ... в моем примере я перебираю около 40 объектов, чтобы найти свойство TFont и изменить его свойство TPitch ... может быть существует путь легче?}
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
begin
for i := 0 to ComponentCount -1 do
if Components[i] is TButton then
TButton(Components[I]).Font.Pitch :=fpFixed ;

end;

[001617]


Опыт читателя

Как определить есть ли некоторое свойство (например, Hint) у объекта?

Nomadic советует:

TypInfo.GetPropInfo (My_Component.ClassInfo, 'Hint') <> nil

Таким образом можно узнать наличие таковой published "прОперти". А вот если это не поможет, то можно и "ломиком" поковыряться посредством FieldAddress. Однако этот метод дает адрес полей, которые перечисляются сразу после объявления класса как в unit'ых форм. А вот ежели "прОперть" нигде не "засветилась" (published) то фиг ты ее достанешь.

А модифицировать значение можно посредством прямой записи по адресу FieldAddress (крайне нежелательно!) либо используя цивилизованный способы, перечисленные в unit'е TypInfo.

Модифицировать кучу объектов можно организовав цикл перебора оных с получением в цикле PropertyInfo объекта и записи в объект на основе PropInfo. [001685]


Пример переменной записи

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

Файл выглядит примерно так:

TFH.......<First record type, первый тип записи>
TBH.......<Second record type, второй тип записи>
TAB........<Third record type, третий тип записи>
TAA........<Fourth record type, четвертый тип записи>

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

Type
TDataTag  = Array [1..3] of Char;
TDataTags = Array [0..NumOfTags-1] of TDataTag;
TDataRec = packed Record
tagfield: TDataTag;
case integer of
0: ( поля для тэга TFH );
1: ( поля для тэга TBH );
2: ..
....
end;
TMultiRec = packed Record
Case Boolean of
false: (строка: Array [0..1024] of Char);
{ должно установать строку максимально возможной длины }
true : ( data: TDataRec );
End;
Const
DataTags: TDataTags = ( 'TFH', 'TBH', .... );
var
rec: TMultirec;

ReadLn( datafile, rec.line );
Case IndexFromDataTag( rec.data.tagfield ) Of
0: ...
1: ...
End;

IndexFromDataTag должен искать передаваемый тэг поля в массиве DataTags. Определите все поля в TDataRec как Array [1..someUpperBound] of Char.

- Peter Below [001041]


Delphi 1

Передача массива записей символов в Memo

Тема: Передача массива записей символов в Memo.

Обработка больших строк в 16-битной версии Delphi задача далеко непростая. Особенно когда строки являются частью структуры записи и вы хотите передать их в TMemo. В данном совете показано как создать структуру записи размером 1000 символов, прочесть в нее содержимое Memo и затем записать ее обратно в Memo. Основной метод, который мы здесь используем - метод Memo GetTextBuf. Используемая структура записи представляет собой простую строку и массив из 1000 символов, но структура могла бы быть сложнее.

unit URcrdIO;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TMyRec = record
MyArray : array [1..1000] of char;
mystr : string;
end;

var
Form1: TForm1;
MyRec : TMyRec;
mylist : TStringlist;
PMyChar : PChar;
myfile : file;
mb : TStream;
implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin
assignfile(myfile, 'c:\testblob.txt');
rewrite(myfile,1);
fillchar(MyRec.MyArray,sizeof(MyRec.MyArray),#0);
pmychar:=@MyRec.MyArray;
StrPCopy(pmychar,memo1.text);
Blockwrite(MyFile,MyRec,SizeOf(MyRec));
closefile(MyFile);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
assignfile(myfile, 'c:\testblob.txt');
reset(myfile,1);
fillchar(MyRec.MyArray,sizeof(MyRec.MyArray),#0);

Blockread(MyFile,MyRec,SizeOf(MyRec));
pmychar:=@MyRec.MyArray;
Memo1.SetTextBuf(pmychar);

end;

end.

[001091]


Delphi 1

Освобождение записей

Для начала необходимо привести объект к нужному типу, например, так:

var
i    : integer;

begin
...
for i := 0 to MyList.Count - 1 do
dispose(PMyRecord(MyList[i]));
MyList.Free;
end;

или

begin
for i := 0 to MyList.Count - 1 do
dispose(PMyRecord(MyList.items[i]));
MyList.Free;

end;

Items - свойство по умолчанию, поэтому вам нет необходимости определять это, хотя обратное не помешает.

Теперь можно заняться созданием работоспособной и полезной функцией. В форме:

var
p : ^mystruct;
begin
new(p);
...
dispose(p);
end;

операторы new() и dispose() в точности соответствуют процедурам getmem() и freemem(), за исключением того, что компилитор распределяет количество байт под размер структуры, на которую ссылается переменная-указатель. По этой причине указатель должен быть типизированным указателем, и следущий код неверен:

var
p : pointer;
begin
new(p);
end;

, поскольку невозможно установить размер памяти, на которую должен ссылаться указатель. С другой стороны, если вы используете getmem() и freemem(), вы можете распределять байты для нетепизированного указателя, например:

var
p : pointer;
begin
getmem( p, 32767 );
...
freemem( p, 32767 );
end;

[001203]


Delphi 1

Файл с множеством записей

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

Type
TSaveHeader = Record
scene    : Integer;
hotspots : LongInt;
talk     : LongInt;
hype     : LongInt;
End;

Var
SaveHeader : TSaveHeader;

Procedure OpenSaveFile(fname : String);
Var
f : File;
i : Integer;
Begin
AssignFile(f, fname);
Reset(f, 1);
BlockRead(f, SaveHeader, Sizeof(TSaveHeader));
{ получаем один набор записи }
Seek(f, SaveHeader.hotspots);
For i := 1 To 50 Do
BlockRead(f, somevar, sizeof_hotspotrec);
{ и так далее }
CloseFile(f);
End;

{ предположим, что файл открыт }
Procedure GetHotspotRec(index : LongInt; Var hotspotrec : THotspot);
Var
offset : LongInt;
Begin
offset := SaveHeader.hotspots + index * Sizeof(THotSpot);
Seek(f, offset);
BlockRead(f, hotspotrec, Sizeof(THotspot));
End;

[001674]


Delphi 2

StrTok для Delphi 2

Я передалал это для работы в Delphi 2.0, код приведен ниже (эта функция первоначально была написана John Cooper 76356,3601 и модифицирована мной для адаптации под Delphi 2.0).

...вот этот код:

function StrTok(Phrase: Pchar; Delimeter: PChar): Pchar;
const
tokenPtr: PChar = nil;
workPtr:  PChar = nil;
var
delimPtr: Pchar;
begin
if (Phrase <> nil) then
workPtr := Phrase
else
workPtr := tokenPtr;

if workPtr = nil then begin
Result := nil;
Exit;
end;

delimPtr := StrPos(workPtr, Delimeter);

if (delimPtr <> nil) then begin
delimPtr^ := Chr(0);
tokenPtr  := delimPtr + 1
end
else
tokenPtr  := nil;

Result   := workPtr;
end;

- Ralph Friedman [001016]


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

Как мне перекодировать строки из Win-кодировки в Dos-кодировку и наоборот?

Nomadic отвечает:

A: CharToOEM, OEMToChar, CharToOEMBuff, OEMToCharBuff. Заметьте однако, что эти функции не умеют делать таких, например, вещей, как koi8-r в DOS и т. п. [001512]


У меня константы могут иметь значение, отличное от заданного. Как лечить?

Nomadic советует:

DX.Bug: Const из другого unit'а дает неверное значение.
Симптоматика -

Unit Main;
Interface

Uses VData;

Const Wko=0.9;
...

Unit VData;
...
Implementation

Uses Main;

Procedure ...;
Begin
{ вот здесь Wko=...E+230 - наверное, бесконечность }
End;

Похоже, это действительно bug, пpичем ОСОБО ОПАСHЫЙ, т.к. может исказить pезультаты pасчетов, не вызвав заметных наpушений pаботы пpогpаммы.

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

Лечится (вpоде бы) указанием типа

const Wko: double = 0.9;

пpавда, тепеpь это уже не совсем константа... [001158]


Delphi 1

Значение вычисляемого поля Paradox вместо 25.55 становится 24.5499999...

Значение вычисляемого поля вместо 25.55 у меня выводится как 24.5499999. Скажите, что я делаю неправильно?

Вы не виноваты в ошибке калькуляции!

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

Вы можете обойти проблему с помощью функции Round:

SalesIncVAT:=round(SalesIncVAT*100)/100;  {дает вам два десятичных порядка}

ничего экстраординарного, это основное свойство математики плавающей точки, которая обеспечивает точность только в заданном интервале десятичных цифр. Точнее говоря, тип float точен для промежуточных целых чисел и для долей, которые представляют собой сумму компонентов в степени 2, любое другое число округляется исходя из переменной точности (7 цифр для "одинарной" точности, 15 для двойной и 20 для расширенной). Можно использовать процедуру Round или str:

var
s : string;
begin
str(SalesIncVat:10:2,s); {10 символов для целой части (с точкой)
и 2 десятичных цифры}
Label1.Caption:=s;

В справке написано, что функция FloatToStr преобразует число в строку с 15 десятичными цифрами - вот почему ваше число отображается столь причудливым образом, попробуйте эту функцию с числами типа 25.5, 25.25, 25.125 или подобными, которые имеют конечное представление в двоичной нотации, и эта проблема должна у вас исчезнуть.

Или используйте функцию FloatToStrF, которой в параметрах необходимо указать общую длину строки и количество десятичных цифр. [001169]


Delphi 1

Классовые/статические/переменные общего доступа

Здесь кроется небольшая хитрость: получение эквивалентной функциональности с помощью классового метода. Просто объявите NodeCount как регулярную типизированную константу в секции implementation вашего файла.

type
TNode = class
public
NodeCount : Integer = 0;  {ЭТО НЕ ДОПУСКАЕТСЯ}
constructor Create;
Class Function GetNodeCount : word;
{
другой необходимый код
}
end;

implementation
const
NodeCount : word = 0;

TNode.Create;
begin
inherited Create;
Inc(NodeCount);
end;

Function TNode.GetNodeCount : word;
begin
result := NodeCount;
end;

Итак, теперь ваш код может выглядеть так, как вы хотели:

SampleNode := TNode.Create;
x := SampleNode.GetNodeCount;

следующая строка также корректна:

x := TNode.GetNodeCount;

[001176]


Чем отличается тип String в Delphi 2 и выше от аналогичного в Delphi 1?

Nomadic советует:

B D2 и выше на самом деле используется тип LongString вместо String, а стаpый тип тепеpь обзывается ShortString (о чем, кстати, написано в help). Из того же help можно узнать, что указатель LongString указывает на nullterminated string и потому возможно обычное пpиведение типа LongString к PChar (о чем я и написал), котоpое сводится пpосто к смене вывески. Там же можно узнать, что длина стpоки хpанится в dword пеpед указателем. Есть также намек на то, что пpи пpисваивании дpугой стpоке инфоpмация не копиpуется, а увеличивается только счетчик ссылок. Более подpобную инфоpмацию можно почеpпнуть из system.pas:

type
StrRec = record
allocSiz: Longint;
refCnt: Longint;
length: Longint;
end;

От себя добавлю:

Сама пеpеменная LongString указывает на байт, непосpедственно следующий за этой пpоцедуpой, там же находится собственно значение стpоки. Значение '' (пустая стpока) пpедставляется как указатель nil, кстати, поэтому сpавнение str='' это быстpая опеpация.

Тепеpь подpобнее о счетчике ссылок. Я уже говоpил, что пpи пpисваивании копиpования не пpоисходит, а только увеличивается счетчик. Когда он уменьшается? Hу, очевидно, когда в pезультате опеpации значение стpоки меняется, то для стаpого значения счетчик уменьшается. Это понятно. Более непонятно, когда освобождаются значения, на котоpые ссылаются поля некого класса. Это пpоисходит в System. TObject.FreeInstance пpи вызове _FinalizeRecord, а инфоpмация беpется из vtInitTable (кстати, здесь же очищаются Variant). Ещё более непонятно, когда освобождаются пеpеменые String, котоpые описаны как локальные в пpоцедуpах/функциях/методах. Здесь pаботает компилятоp, котоpые вставляет эти неявные опеpации в код этой функции.

Тепеpь о типе PString. Hа самом деле пеpеменные этого типа указывают на такие же значения, как и LongString, но для пеpеменных этого типа для всех опеpаций по созданию/копиpованию/удалению нужно помнить об этих самых счетчиках ссылок. Иногда без этого типа не обойтись. Вот опеpации для этого типа (sysutils.pas):

{ String handling routines }

{ NewStr allocates a string on the heap.
NewStr is provided for backwards compatibility only. }
function NewStr(const S: string): PString;

{ DisposeStr disposes a string pointer that was
previously allocated using NewStr.
DisposeStr is provided for backwards compatibility only. }
 procedure DisposeStr(P: PString);

{ AssignStr assigns a new dynamically allocated
string to the given string pointer.
AssignStr is provided for backwards compatibility only. }
 procedure AssignStr(var P: PString; const S: string);

Можно отметить, что явно задать использование long strings можно декларацией

var
sMyLongString: AnsiString; // long dinamically allocated string
sMyWideString: WideString; // wide string (UNICODE)
sMyShortString1: ShortString; // old-style string
sMyShortString2: String[255]; // old-style string, no more than 255 chars

Хотелось бы также предупредить наиболее частные ошибки при использовании длинных строк:

  • Если Вы передаёте указатель PChar на буфер, взятый от длинной строки, в функцию, которая может изменить содержание буфера, то убедитесь, что на этот буфер указывает только одна строка. Это верно в случаях сложения строк, вызова UniqueString или SetLength и некоторых других;
  • Если Вы используете длинные строки как аргументы или результаты для функций, располагающихся в DLL, то в DLL надо использовать модуль ShareMem;
  • Не используйте длинные строки как члены структур типа record. Используйте там короткие строки или array[0..n] of char. Также нельзя использовать в структурах типа record динамические массивы. Данные ограничения отсутствуют для классов.
[001181]


Delphi 1

Различия TMEMOFIELD

Во-первых, если аргумент size у GetMem равен нулю, GetMem устанавливает указатель в nil (не отбрасывайте такой способ, но разумней самому установить его в nil). Также в отладчике вы могли бы проверять значение DataSize (или getTextLen) перед самим вызовом.

(Проигнорируйте следующий параграф, если Table1Notes не Memo.)
Во-вторых, если Table1Notes - Memo-поле, вы, вероятно, захотите использовать Table1Notes.getTextLen, не DataSize, поскольку DataSize возвращает размер сегмента буфера записи (0-254), тогда как getTextLen возвратит вам реальный размер Memo. (Для строкового поля DataSize работать будет, но очень странно, поскольку возвращает ноль.) Также вы можете воспользоваться getTextBuf вместо getData, не знаю точно почему, но мои многочисленные экспериметны показали, что getTextBuf работает правильно и устойчиво, а getData нет.

Поскольку "wordwrapping" (перенос слов) доступен в вашем приложении, вы можете заменить символы #10 (перевод строки) и #13 (возврат каретки) на пробелы, например так:

cursor: pchar;

cursor := ваш буфер;
while cursor^ <> #0 do
if (cursor^ = #13) or (cursor^ = #10) then cursor^ := ' ';

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

out, in: pchar;

out := ваш буфер;
in := out;
while in^ <> #0 do begin
if (in^ <> #10) and (in^ <> #13) then begin
out^ := in^;
inc (out);
end;
inc (in);
end;
out^ := #0;

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

out, inn: PChar;

out := ваш буфер;
inn := out;
while in^ <> #0 do begin
if (in^ = #10) then begin
end
else if (in^ = #13) then begin
if (in+1)^

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

out, inn: PChar;

out := buf;
inn := out;
while inn^ <> #0 do begin
if (inn^ = #10) or ((inn^ = #13) and ((inn+1)^ <> #10)) then begin
out^ := ' ';
Inc(out);
end
else if (inn^ = #13) then
{ только CR, игнорируем }
else begin
out^ := inn^;
Inc(out);
end;
Inc(inn);
end;
out^ := #0;
{ буфер теперь закрыт }

Непроверенное: эффект уменьшения размера (путем установки терминатора #0) этого PChar позволит уменьшить время компиляции массивов и буферов GetMem, что же будет при использовании StrAlloc/StrDispose?

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

procedure TForm1.RemoveSpaces(var InBuf: PChar; Size: Word);
var
Input,
OutPut,
Orig: PChar;
begin
GetMem(Output, Size);
input := Inbuf;
Orig := Output;
while input^ <> #0 do
begin
if (input^ <> #10) and (input^ <> #13) then
begin
output^ := input^;
inc (output);
end;
inc (input);
end;
Output^ := #0;
Output := Orig;
InBuf := Output;
end;

Я все еще немало удивлен тому как работает GetData! Я все еще не хочу использовать TMemo! Если кто-то может решить эту проблему, я буду очень рад! Пока же я готовлю для вас материал, включающий новые процедуры печати! Наведем порядок в беспорядке! Я уже имею реализацию вывода текста с любым шрифтом и в любой позиции, выраженной в дюймах, и это только начало! Но что я думаю действительно классно вышло, так это диманическая сетка! Вы можете создавать сетку с любым количеством строк и колонок. Назначьте текст и ячейку, установите горизонтальное и вертикальное выравнивание, выберите стиль границы для каждой ячейки и изучите множество других способов манипулирования и печати сетки! [001186]


Delphi 1

Функция, возвращающая тип

Вы можете сделать это в C++. В ObjectPascal это также можно сделать, смотрите пример:

// функция Chameleon, возвращающая тип сгенерированного исключения

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type

MyBoolean = class
public
Value : boolean;
end;

MyInteger = class
public
Value : integer;
end;

MyClass = class
public
Value : TStrings;
end;

TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure MyProc;
function Chameleon : boolean;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.Chameleon : boolean;
var
b : MyBoolean;
i : MyInteger;
c : MyClass;
r : integer;
begin
r := Random(3);
case r of
0 : begin
b := MyBoolean.Create;
raise b;
end;
1 : begin
i := MyInteger.Create;
raise i;
end;
2 : begin
c := MyClass.Create;
raise c;
end;
end;
end;

procedure TForm1.MyProc;
begin
try
Chameleon;
except
on MyBoolean do ShowMessage('Функция возвратила класс MyBoolean');
on MyInteger do ShowMessage('Функция возвратила класс MyInteger');
on MyClass do ShowMessage('Функция возвратила класс MyClass');
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Chameleon;
end;

end.

Взгляните на тип данных Variant в D2: следующий код

function AnyType(const TypeParm: integer): Variant;
begin
case TypeParm of
1:  Result := 1;
2:  Result := 2.0;
3:  Result := 'Три';
4:  Result := StrToDate('4/4/1944');
end;
end;

абсолютно бестолковый, но полностью корректный!

Следующий код содержит объявление трех функций, принимающих на входе один и тот же параметр, но выдающих результаты различных типов (результат физичиски один и тот же, и занимает он 4 байта). Я не думаю, что можно одурачить delphi, чтобы с помощью этого метода возвратить строку. Это может привести к разрушению менеджера кучи. Вместо этого вызывайте необходимую вам функцию. Каждый вызов передается MyFuncRetAnything, а P1 определяет возвращаемый тип. Если хотите, можете написать другую обертку, делающую для вас еще и приведение типов.

3 вызова, 1 код.

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

{моя форма имеет 3 метки, одну кнопку и этот код}

var
MyFuncRetInt : Function (P1, P2 : Integer) : Integer;
MyFuncRetBool : Function (P1, P2 : Integer) : LongBool;
MyFuncRetPointer : Function (P1, P2 : Integer) : Pointer;

function MyFuncRetAnything (P1, P2 : Integer) : Integer;
var
RetPointer : Pointer;
RetBool : LongBool;
RetInteger : Integer;
begin
RetPointer := nil;
RetBool := False;
RetInteger := 4711;
case P1 of
1 : Result := Integer (RetPointer);
2 : Result := Integer (RetBool);
3 : Result := RetInteger;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if MyFuncRetBool (2, 1900) then
Label1.Caption := 'True'
else
Label1.Caption := 'False';
Label2.Caption := IntToStr (MyFuncRetInt (3, 1900));
Label3.Caption := IntToHex (Integer (MyFuncRetPointer (1, 1900)), 16);
end;

initialization
MyFuncRetInt := @MyFuncRetAnything;
MyFuncRetBool := @MyFuncRetAnything;
MyFuncRetPointer := @MyFuncRetAnything;
end.

[001192]


Delphi 1

Преобразование формата MS BINARY в IEEE

"Использование, независимое от машинного уровня" не так просто в реализации с процессорами, выпущенными до Intel-го математического сопроцессора 80x87. Я не уверен в том, что процессоры 80x86 имели какие-либо родные инструкции для выполнения операций с плавающей точкой. По-видимости, поэтому Microsoft создал свой собственный формат для чисел с плавающей точкой; он сам осуществлял всю арифметику с помощью библиотеки времени выполнения. Сегодня 80x87 осуществляет такую арифметику автоматически, и IEEE теперь стандарт.

Delphi хранит следующие типы чисел с плавающей точкой в формате IEEE:

  Single      4 байт
  Double      8 байт
  Extended   10 байт
Обратите внимание на то, что тип Real (6 байт) отсутствует в данном списке. Я могу ошибаться, но мне кажется что тип Real - синтезированный в Pascal тип; он может без особых проблем существовать на процессорах ниже 80x87.

[В сторону: электронная справка Delphi сообщает, что по умолчанию (через директиву компилятора $N+), компилятор будет генерировать код для выполнения ВСЕХ операций с плавающей точкой, используя инструкции 80x87, включая тип Real. Также, для работы с типом Real, компилятор генерирует вызовы библиотеки времени выполнения, или же я полностью неправ в вышесказанном! :) ]

Во всяком случае, в электронной справке Visual Basic я увидел, что VB оперирует с типами данных Single и Double, которые также относятся к типу IEEE, и идентичны Delphi-типам Single и Double. Тем не менее, в справке отсутствует упоминание "Microsoft Binary Format".

Для того, чтобы разобраться в вопросе, я "опустился" до DOS и запустил QBasic, новую версию интерпретатора Microsoft QuickBasic, включаемую теперь в поставку DOS. Если мы посмотрим в электронную справку, то увидим следующее:

MKSMBF$ и MKDMBF$ преобразуют числа формата IEEE в "числовые строки" формата Microsoft-Binary, которые могут храниться в строковых переменных типа FIELD. CVSMBF и CVDMBF преобразуют эти строки обратно в числа формата IEEE.

MKSMBF$(выражение-единичной-точности!)
MKDMBF$(выражение-двойной-точности#)
CVSMBF (4-байтовая-числовая-строка)
CVDMBF (8-байтовая-числовая-строка)

   Функция     Возвращаемое значение

   MKSMBF$     4-байтовая строка, содержащая число в формате Microsoft-Binary-format
   MKDMBF$     8-байтовая строка, содержащая число в формате Microsoft-Binary-format
   CVSMBF      Число единичной точности в формате IEEE
   CVDMBF      Число двойной точности в формате IEEE
Эти функции могут оказаться полезными при поддержке файлов данных, созданных с помощью старых версий Basic.

Суммируя вышесказанное, можно дать 3 рекомендации для получения доступа к вашим "MetaStock"-файлам:

  1. Напишите вашу программу в QBasic/DOS
  2. Найдите замену (с учетом совместимости с Delphi) для функций преобразований, упомянутых выше.
  3. Напишите эти функции сами. Вы должны найти документацию для старых типов Single и Double, применявшихся в "Microsoft Binary Format", возможно в справочных файлах старых версий MS Basic.
[001194]


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

Почему у меня record a : word; b : longint end; имеет размер восемь байт вместо шести?

Nomadic лаконично отвечает:

A: RTFM packed, $A. [001551]


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

Как корректно сравнивать и выполнять арифметические действия с четырехбайтными беззнаковыми целыми числами (DWORD)?

Nomadic лаконично отвечает:

Hичего лучшего, чем PChar(a) < PChar(b) пока не пpидумали. [001593]


Письмо читателя

С каким числовым форматом Delphi работает быстрее всего?

Nomadic отвечает:

Простой тест: под рукой прога для вычисления координат цвета по спектру из 10000 точек, вычислений там прилично:

 type     time, sec
-+-----------------
 single     2.20
 double     3.63
 real       4.28
 extended   5.95
[001706]


Delphi 1

Хранение TColor

Храните это как IntToStr(thecolor); Нет необходимости использовать 16-ричное исчисление. [001715]


Письмо читателя

Сравнение чисел с плавающей точкой

Олег Кулабухов отвечает на вопрос:

У меня два числа с плавающей запятой неправильно сравниваются! Задаю if d1=d2 ..., или if d1<>d2, а результат иногда неверный. В чем дело? Это баг Дельфи?

Нет. Просто в отличие от целочисленных IEEE числа с плавающей запятой являются приблизительными значениями и вы не должны использовать = или <> для сравнивания двух чисел такого типа. Вместо этого вычтите из одного числа другое и сравните разницу с очень малой величиной.

Например.

if abs(d1-d2) < 0.00001 then
ShowMessage('D1 и D2 равны');

[001807]


Письмо читателя

Как показать число, разделив каждые три цифры запятыми?

Олег Кулабухов отвечает на вопрос:

procedure TForm1.Button1Click(Sender: TObject);
var
i : integer;
begin
i := 12345678;
Memo1.Lines.Add(FormatFloat('#,', i));
end;

[001854]


Delphi 1

Статические переменные

Да, это работает. Объявите переменную в секции const, например:

procedure P;
const
MyVariable : Integer = 0;
begin
Inc(MyVariable);
end;

В нашем примере переменная MyVariable содержит количество вызовов P.

Тем не менее, это лучшее решение, чем использование взамен какого-либо поля объекта (если это возможно). [001202]


Переключение ключей компилятора

Быстрый и легкий путь вкл/выкл директив компилятора. Весь Borland pascal.

{$R+,L+} {Это директива компилятора плюс комментарий}

{{$R+,L+} {Эта строка - два комментария, похоже на картинку?}

Аналогично:

{$DEFINE DEVEL}
{$IFDEF DEVEL}
 ......
{$ELSEIF}

Переключение с "devel" компиляции на не-"devel" версию происходит простым прибавлением второй скобки в первой строке. Единственное нажатие клавиши позволит переключать вам ключи компилятора.

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

if i=0 then inc(i);     {выражение+комментарий}

ср.

{     if i=0 then inc(i);     {закомментарена вся строка}

Сравните - два нажатия клавиш для установки фигурной скобки или десяток нажатий для установки (* *) до и после строки. Клавиша Del поможет вам вернуться в предыдущее состояние.

- P Gallagher [001044]


Получение ссылки на класс из объекта I

Мне необходимо получить ссылку на класс из объекта. Например, если у меня есть ссылка на объект (например, указатель на экземпляр TLabel), то мне необходимо получить ссылку на класс (например, ссылка на класс TLabel) для того, чтобы мне еще создать необходимое количество объектов данного класса. Другими словами, мне нужно дублировать экземпляры классов, создаваемые кем-то еще.

Класс, о котором идет речь, в Delphi не зарегистрирован (его нет в палитре), поэтому GetClass('TLabel') не работает, даже если экземпляры класса существуют, работать с ними можно только через RTTI. Вдобавок к этому, у меня нет даже кода класса, поэтому работа через RTTI - единственный выход.

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

type
TLabelClass = class of TLabel;

procedure TForm1.Button1Click(Sender: TObject);
var
Ref : TLabelClass;
New : TLabel;
begin
Ref := TLabelClass(Label1.ClassType);
New := Ref.Create(Self);
New.Parent := Self;
New.Caption := 'Фантастика!';
end;

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

New.Assign(Label1);

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

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

TCustomer = class(TComponent)
private
FCompany : string;
FPhone : LongInt;
published
property Company: string read FCompany write FCompany;
property Phone: LongInt read FPhone write FPhone;
end;

Вы можете зарегистрировать класс для потоковой системы следующим образом:

RegisterClass(TCustomer);

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

После регистрации классов, вы можете реплицировать их следующим образом:

procedure TForm1.Button1Click(Sender: TObject);
var
Ref : TComponentClass;
New : TComponent;
Stream : TMemoryStream;
begin
Ref := TComponentClass(Label1.ClassType);
New := Ref.Create(Self);
Stream := TMemoryStream.Create;
try
Stream.WriteComponent(Label1);
Stream.Position := 0;
Stream.ReadComponent(New);
finally
Stream.Free;
end;
end;

- Rick Rogers [001123]


Получение ссылки на класс из объекта II

Мне необходимо получить ссылку на класс из объекта...

TObject.ClassType

var
ClassRef : TComponentClass;
NewComp:TComponent;
begin
TClass(ClassRef) := Sender.ClassType;
NewComp := ClassRef.Create(Self);
...

- Pat Ritchey [001125]


Delphi 1

Работа с комментариями в большом куске кода

В Паскале существует 2 способа обозначить комментарии - {} и (* *). Вы можете вставлять один комментарий в другой (осуществлять вложенность). Следовательно, вставляя (* в начале вашего блока, и *) в конце, вы все еще можете работать с вложенными комментариями типа { }. [001436]


Delphi 1

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

Вызовите диалог редактирования полей (Fields Editor), дважды щелкнув на компоненте TTable или TQuery, расположенном на вашей форме (или выбрав в контекстном меню пункт Fields Editor). Добавьте все поля, с которыми вы хотите работать в форме (даже если вы хотите, чтобы они были невидимы, но вам необходим к ним доступ -- для таких полей установите свойство visible в false). Затем щелкните на "Define..." (определить) для добавления вычисляемого поля. Введите имя вычисляемого поля, отличающееся от имен других полей таблицы, выберите тип (вероятно, StringField) и задайте длину (20 будет в самый раз). Убедитесь в том, что напротив поля 'calculated' стоит галочка. Затем создайте для вашего объекта TTable или TQuery обработчик события 'OnCalcFields'. В этом обработчике вы берете значения реальных полей таблицы, делаете вычисления, и помещаете результаты в объект вычисляемого поля, который вы только что создали. После этого значение выводится в TDBGrid, или в элементе управления TDBText, если вы решили использовать форму вместо табличной сетки.

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

function AgeStr(aDate: TDateTime): string;
var
DaysOld : Double;
Years,
Months  : Integer;
begin
DaysOld := Date - aDate;

Years := Trunc(DaysOld / 365.25);
DaysOld := DaysOld - (365.25 * Years);
Months := Trunc(DaysOld / 30.41);

Result := Format('%d лет, %d месяцев',[Years, Months]);
end;

В моем случае метод OnCalcFields выглядит так:

procedure TEntryForm.TableNameOrderCalcFields(DataSet: TDataset);
begin
TableNameOrderAge.AsString := AgeStr(TableNameOrderDateOfBirth.AsDateTime);
end;

[001227]


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

Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?

Nomadic отвечает:

Resync( [rmExact, rmCenter] );

[001369]


Как создать вычисляемые поля во время исполнения программы (Calculated fields at RunTime)?

Nomadic отвечает:

Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки.

Здесь немного исправленный пример из этой книги -

function TMyClass.CreateCalcField( const AFieldName: string; AFieldClass: TFieldClass; ASize: Word ): TField;
begin
Result := FDataSet.FindField( AFieldName ); // Field may already exists!
if Result<>nil then Exit;
if AFieldClass = nil then
begin
DBErrorFmt( SUnknownFieldType, [AFieldName] );
end;
Result := FieldClass.Create( Owner );
with Result do
try
FieldName := AFieldName;
if ( Result is TStringField ) or ( Result is TBCDField ) or ( Result is TBlobField ) or ( Result is TBytesField ) or ( Result is TVarBytesField ) then
begin
Size := ASize;
end;
Calculated := True;
DataSet := FDataset;
Name := FDataSet.Name + AFieldName;
except
Free; // We must release allocated memory on error!
raise;
end;
end;

[001385]


Хитрости многопользовательского доступа к БД

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

В модуле DBIPROCS Delphi 1.0 и в BDE.INT 2.0 существует классная функция с именем DBISETLOCKRETRY(n).

Синтаксис - DBISetLockRetry(n), где n - количество секунд ожидания перед повторной попыткой вставки, редактирования или другой операцией с таблицей. DBISetLockRetry(-1) будет бесконечно пытаться получить доступ к вашей таблице.

Хорошее место для вызова функции - обработчик события TableAfterOpen. В этом случае все, что вам нужно сделать, это:

DBISetLockRetry(x);

Если вы используете Delphi 1.0, не забудьте включить в вашу программу DBIProcs. В Delphi 2.0 включите BDE.

Мой заказчик и я разработали многопользовательскую базу данных по вашему рецепту, до этого наши пользователи получали сообщения "File is Locked" (файл заблокирован), "Table is Busy" (таблица занята), "Record Locked" (запись заблокирована) и др. Мы также пробовали Session.Netdir, но он не помог нам. Поскольку мы добавили в код эту строку, никаких блокировок не было. Частота обращений пользователей к базе достаточно велика (80 kpm). Мы разработали "измеритель скорости доступа" с 2 открытыми сессиями на двух компьютерах в сети Novell 4.1. Две сессии занимались вставкой, две другие редактированием, а мы сами занимались посылкой данных с частотой около 65 записей в минуту в течение операций редактирования и 85 в течение вставки. Сеть чуть не захлебнулась от такой работы. Утилизация файлового сервера была до нас около 60%. Не плохо для всего! Я думаю Borland необходимо задокументировать такой подход, чтобы другие не становились хакерами типа нас! :)

Эти требования обязательны при разработке многопользовательских приложений Delphi с использованием файлов Dbase или Paradox.

- Ted Bulmanski [001007]


Delphi 2

Выполнение запросов к базе данных в фоне

Тема: Выполнение запросов к базе данных в фоновом потоке

Данный документ объясняет как выполнить запрос в фоновом режиме, используя класс TThread. Для получения общей информации о классе TThread, пожалуйста обратитесь к документации Borland и электронной справке. Для понимания данного документа вам необходимо иметь представление о том, как работать с компонентами для работы с базами данных, поставляемых в комплекте с Delphi 2.0.

Для осуществления потокового запроса необходимо выполнение двух требований. Во-первых, потоковый запрос должен находиться в своей собственной сессии с использованием отдельного компонента TSession. Следовательно, на вашей форме должен находиться компонент TSession, имя которого должно быть назначено свойству SessonName компонента TQuery, используемого для выполнения потокового запроса. Для каждого используемого в потоке компонента TQuery вы должны использовать отдельный компонент TSession. При использовании компонента TDataBase, для отдельного потокового запроса должен также использоваться отдельный TDataBase. Второе требование заключается в том, что компонент TQuery, используемый в потоке, не должен подключаться в контексте это потока к TDataSource. Это должно быть сделано в контексте первичного потока.

Приведенный ниже пример кода иллюстрирует описываемый процесс. Данный модуль демонстрирует форму, которая содержит по два экземпляра следующих компонентов: TSession, TDatabase, TQuery, TDataSource и TDBGrid. Данные компоненты имеют следующие значения свойств:

  Session1
    Active	True;
    SessionName	"Ses1"

  DataBase1
    AliasName	"IBLOCAL"
    DatabaseName	"DB1"
    SessionName	"Ses1"

  Query1
    DataBaseName	"DB1"
    SessionName	"Ses1"
    SQL.Strings	"Select * from employee"

  DataSource1
    DataSet	""

  DBGrid1
    DataSource	DataSource1

  Session2
    Active	True;
    SessionName	"Ses2"

  DataBase2
    AliasName	"IBLOCAL"
    DatabaseName	"DB2"
    SessionName	"Ses2"

  Query2
    DataBaseName	"DB2"
    SessionName	"Ses2"
    SQL.Strings	"Select * from customer"

  DataSource2
    DataSet	""

  DBGrid1
    DataSource	DataSource2
Обратите внимание на то, что свойство DataSet обоих компонентов TDataSource первоначально никуда не ссылается. Оно устанавливается во время выполнения приложения, и это проиллюстрировано в коде.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs,StdCtrls, Grids, DBGrids, DB, DBTables;

type

TForm1 = class(TForm)
Session1: TSession;
Session2: TSession;
Database1: TDatabase;
Database2: TDatabase;
Query1: TQuery;
Query2: TQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
GoBtn1: TButton;
procedure GoBtn1Click(Sender: TObject);
end;

TQueryThread = class(TThread)
private
FSession: TSession;
FDatabase: TDataBase;
FQuery: TQuery;
FDatasource: TDatasource;
FQueryException: Exception;
procedure ConnectDataSource;
procedure ShowQryError;
protected
procedure Execute; override;
public
constructor Create(Session: TSession; DataBase:
TDatabase; Query: TQuery; DataSource: TDataSource);
virtual;
end;

var
Form1: TForm1;

implementation

constructor TQueryThread.Create(Session: TSession; DataBase: TDatabase; Query: TQuery; Datasource: TDataSource);
begin
inherited Create(True);    // Создаем поток c состоянием suspendend
FSession := Session;       // подключаем все privat-поля
FDatabase := DataBase;
FQuery := Query;
FDataSource := Datasource;
FreeOnTerminate := True;   // Устанавливаем флаг освобождения потока после его завершения
Resume;                    // Продолжение выполнения потока
end;

procedure TQueryThread.Execute;
begin
try
{ Выполняем запрос и подключаем источник данных к компоненту TQuery,
вызывая ConnectDataSource из основного потока
(для этой цели используем Synchronize)}
FQuery.Open;
Synchronize(ConnectDataSource);
except
{ Ловим исключение (если оно происходит) и его дескриптор
в контексте основного потока (для этой цели используем
Synchronize). }
FQueryException := ExceptObject as Exception;
Synchronize(ShowQryError);
end;
end;

procedure TQueryThread.ConnectDataSource;
begin
FDataSource.DataSet := FQuery;  // Подключаем DataSource к TQuery
end;

procedure TQueryThread.ShowQryError;
begin
Application.ShowException(FQueryException); // Обрабатываем исключение
end;

procedure RunBackgroundQuery(Session: TSession; DataBase: TDataBase; Query: TQuery; DataSource: TDataSource);
begin
{ Создаем экземпляр TThread с различными параметрами. }
TQueryThread.Create(Session, Database, Query, DataSource);
end;

{$R *.DFM}

procedure TForm1.GoBtn1Click(Sender: TObject);
begin
{ Запускаем два отдельных запроса, каждый в своем потоке }
RunBackgroundQuery(Session1, DataBase1, Query1, Datasource1);
RunBackgroundQuery(Session2, DataBase2, Query2, Datasource2);
end;

end.

Метод TForm1.GoBtn1Click является обработчиком события нажатия кнопки. Данный обработчик события дважды вызывает процедуру RunBackgroundQuery, это случается при каждой передаче новых параметров компонентам для работы с базой данных. RunBackgroundQuery создает отдельный экземпляр класса TQueryThread, передает различные компоненты для работы с базой данных в его конструктор, который, в свою очередь, назначает их закрытым полям TQueryThread.

TQueryThread содержит две определенные пользователем процедуры: ConnectDataSource и ShowQryError. ConnectDataSource связывает FDataSource.DataSet с FQuery. Тем не менее, это делается в первичном потоке с помощью метода TThread.Synchronize. ShowQryError обрабатывает исключение в контексте первиного потока, также используя метод Synchronize. Конструктор Create и метод Execute снабжены подробными комментариями.

[001012]


Delphi 2

Получение физического пути к таблице

Тема: Получение физического пути к таблице
Отправлено: Август 13, 1996
Автор: Xavier Pacheco

Если ссылка на таблицу получена через псевдоним, получить физический путь к ней не так просто. Для получения этого пути необходимо использовать функцию BDE DbiGetDatabaseDesc. Данной функции в качестве параметров передаются имя псевдонима и указатель на структуру DBDesc. Структура DBDesc будет заполнена информацией, относящейся к этому псевдониму. Определение структуры:

pDBDesc = ^DBDesc;
DBDesc = packed record          { Описание данной базы данных }
szName          : DBINAME;    { Логическое имя (или псевдоним) }
szText          : DBINAME;    { Описательный текст }
szPhyName       : DBIPATH;    { Физическое имя/путь }
szDbType        : DBINAME;    { Тип базы данных }
end;

Физическое имя/путь будет содержаться в поле szPhyName структуры DBDesc.

Возможные значения, возвращаемые функцией DBIGetDatbaseDesc:

DBIERR_NONE             Описание базы данных для pszName было успешно извлечено.
DBIERR_OBJNOTFOUND      База данных, указанная в pszName, не была обнаружена.
Приведенный ниже пример кода показывает как можно получить физический путь для компонента TTable, использующего псевдоним DBDemos:

var
vDBDesc: DBDesc;
DirTable: String;
begin
Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
ShowMessage(DirTable);
end;

[001027]


Delphi 1

Cancel в связанных таблицах

В книге 'Delphi unleashed' на странице 520 автор написал:

'..., вы можете делать откат все время до тех пор, пока прямо или косвенно не сделаете постинг данных.'

Моя проблема дважды возникала в случае ExTable.Edit в различных процедурах. Код был примерно таким:

Procedure1 ....
begin

ExTable.Edit ;
ExTable.FieldByName('...').AsString := ...;
...

end;

procedure2 .....
begin

ExTable.Edit;
.....
end;

Процедура CancelSpdBtnClick была вызвана после этих двух процедур. Действительно, прежде, чем делать откат, постинг был косвенно вызван между двумя вызовами ExTable.Edit. Теперь после такой модификации все работает как часы. [001221]


Delphi 1

Отображение формы ввода в БД CUSTOMER из рабочей формы ORDER

В моем проекте имеется подобная функция, определяющая количество элементов:

  1. В обработчике события OnClick я создаю форму ввода данных и вывожу ее командой .ShowModal. Затем я проверяю результат .ModalResult - и, если он равен mrOk, я передаю запись, в противном случае делаю отмену.

  2. Я поместил имя модуля с формой ввода данных в список используемых модулей главной формы.
Вот базовая схема моего кода:

procedure TFrmItemNav.BtnChangeLocClick(Sender: TObject);
{var DlgItemLoc: TDlgItemLoc;}
begin
DlgItemLoc := TDlgItemLoc.Create(FrmItemNav);
DlgItemLoc.ShowModal;

if DlgItemLoc.ModalResult = mrOk then
{делаем все, что необходимо для постинга данных}
else
{очищаем и делаем Cancel};

DlgItemLoc.Free;
end;

[001264]


Delphi 1

Отображение определенных полей БД

Вот что можно сделать во время выполнения программы:

Table1.FieldByName(RemovedFieldName).Visible := False;

или

Table1.Field[removedFieldNumber-1].Visible := false;

[001265]


Delphi 1

Из базы данных в переменные

Примерно так вы можете программным путем извлечь содержимое поля:

aValue := TMyTable.FieldByName('SomeField').AsText;

или

aValue := TMyTable.FieldByName('SomeField').AsInteger;

или

aValue := TMyTable.Fields[1].AsFloat;

В действительности здесь вы получаете объект TField от объекта TTable (или TQuery), и затем вызываете соответствующий метод объекта TField для получения самих данных. Вы можете также изменить значение самого поля, но только в случае, если объект TTable находится в режиме вставки (Insert) или редактирования (Edit). Члены AsFloat, AsInteger, AsDateTime и AsString в действительности являются свойствами, и как таковые также могут принимать значения. С помощью Редактора Полей (Fields Editor, для вызова которого достаточно дважды щелкнуть на объекте TTable или TQuery) также возможно создание объектов-полей. Эти объекты могут быть использованы вместо получения их каждый раз от объекта TTable или TQuery. [001281]


Получение информации о таблице

Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:

procedure TForm1.ShowFields;
var
i : Word;
begin
Memo1.Lines.Clear;
Table1.FieldDefs.Update;                     { должно быть вызвано,
если Table1 не активна }
for i := 0 to Table1.FieldDefs.Count - 1 do
With Table1.FieldDefs.Items[i] do
Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
end;

Если вам просто нужны имена полей (FieldNames), то используйте метода TTable GetFieldNames:
GetIndexNames для получения имен индексов:

var FldNames, IdxNames : TStringList

begin

FldNames := TStringList.Create;
IdxNames := TStringList.Create;

If Table1.State = dsInactive then Table1.Open;
Table1.GetFieldNames(FldNames);
Table1.GetIndexNames(IdxNames);

{...... используем полученную информацию ......}

FldNames.Free; {освобождаем stringlist}
IdxNames.Free;
end;

Для получения информации об определенном поле вы должны использовать FieldDef. [001283]


Delphi 1

Обмен данными между TMemoField и TMemo

Procedure TMemoToTMemoField;
begin
TMemoField.Assign( TMemo.Lines );
end;

Procedure TMemoFieldToTMemo;
VAR aBlobStream : TBlobStream;
begin
aBlobStream := TBlobStream.Create(TMemoField, bmRead);
TMemo.Lines.LoadFromStream( aBlobStream );
aBlobStream.Free;
end;

[001295]


Если в транзакции изменена какая-то таблица, то для другого пользователя блокируется вся таблица, до окончания транзакции. Как лечить?

Nomadic отвечает:

По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных блокировок вместо эксклюзивной табличной блокировки:

UPDATE orders SET customer_id=NULL FROM orders(PAGLOCK) WHERE customer_id=32;
Блокиpовка на всю таблицу пpи UPDATE ставится только в том случае, если по пpедикату нет индекса. Так, можно пpосто пpоиндексиpовать таблицу orders по полю customer_id, и не забывать делать UPDATE STATISTIC, хотя будет работать и с PAGLOCK. Просто не факт, что UPDATE всегда делает табличную блокировку. [001299]


Delphi 1

Форма Мастер-Деталь

...это нормально в двух случаях:

  1. Эксперт баз данных по умолчанию создает запрос, где RequestLive установлен в False; если вы хотите что-либо изменить, установите RequestLive в True.

  2. При отношениях "один к многим", из-за правил сохранения целостности, вам дозволяется делать изменения только на форме "многих", а не на форме "один".
    BTW: правильно, что вы об этом задумались. Предположим, что вы имеете отношение "один к многим", где "один" - ваши клиенты, а "многие" - их счета-фактуры: естественно, счетов, относящихся к клиенту, может быть больше, чем один. Если ваша система позволяет редактировать информацию о клиентах, например, удалять записи, то вскоре вы можете обнаружить, что некоторые счета не будут иметь отношения к кому бы то ни было.
[001300]


Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?

Nomadic отвечает:

Я делал так (это кусок компонента):

if Picture.Graphic is TJPegImage then
begin
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Picture.Graphic.SaveToStream(bs);
bs.Free;
end
else if Picture.Graphic is TBitmap then
begin
Jpg:=TJPegImage.Create;
Jpg.CompressionQuality:=...;
Jpg.PixelFormat:=...;
Jpg.Assign(Picture.Graphic);
Jpg.JPEGNeeded;
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Jpg.SaveToStream(bs);
bs.Free;
Jpg.Free;
end else Field.Clear;

[001303]


Delphi 1

Как исключить показ поля P_RECNO?

Вы можете сделать:

1. отредактируйте TTable для исключения P_RECNO

или

2. установите

TableX.FieldbyName('P_RECNO').Visible := False;

Это можно сделать также и с помощью редактора полей (Fields Editor), который связан не с DBGrid, а напрямую с компонентом Table. Для вызова редактора щелкните правой кнопкой мыши на компоненте Table и выберите самый верхний пункт контекстного меню. Добавьте все поля в список полей и выделите то поле, которое вы не хотите показывать в DBgrid. Найдите в Инспекторе Объектов свойство Visible, и установите его в False.

//
Если у вас имеется компонент TTable, дважды щелкните на иконке компонента (расположенной на форме), и вы получите в диалоге список полей, имеющих отношение к соответствующей таблице щелкните на одном из полей и проверьте в Инспекторе Объектов свойство Visible, оно должно быть установлено в False.
// [001304]


Информация из одной таблицы и набора данных на двух формах

  1. Добавьте на вторую форму (form2) компонент TTable

  2. В режиме разработки присвойте этой таблице такие же значения, как и у таблицы, расположенной на form1

  3. В секции IMPLEMENTATION у form2 создайте следующий фрагмент кода:

    unit form2;

    interface
    {...}
    implementation
    uses
    form1;
    {...}

  4. Подключите процедуру к OnCreate-событию в form2 (через Инспектор Объектов)

  5. Добавьте к этой процедуре следующую строку:

    table1 := form1.table1;

    В режиме разработки свяжите все компоненты с table1, расположенным на form1.

    Остается только решить проблему синхронизации. Попробуйте следующее:

      - На Form1
    разместите Table1
    разместите DataSource1
        установите DataSource1.DataSet :=  Table1
    разместите DataGrid
        установите DataSource := DataSource1
    Ну это все просто и стандартно. Поехали дальше:
      - На Form2
    разместите DataSource1 (#1 для этой формы)
    разместите любые другие необходимые вам БД-компоненты;
        укажите у них в качестве источника данных DataSource1
    В обработчике события OnCreate для этой формы (например, FormCreate),
    поместите следующий код:
    With Form1 do
    begin
    Form2.DataSource1.DataSet := Table1;
    end;

        Данный код подключает Table1 на Form1 к DataSource от Form2.
        После таких действий данные будут отображены на Form2 и будут
    "синхронизированы" с данными, отображаемыми на Form1 (поскольку
    в действительности используется одна таблица).
    Единственное здесь предостережение - если вы используете TDatabase, так как это может быть не то, что вы хотите. Компонент TDatabase не обязателен для получения доступа к базам данных, но, тем не менее, он обеспечивает вас дополнительным контролем в приложениях класса клиент/сервер.

    Таким образом, если приложение не работает в среде клиент/сервер, нет необходимости использовать TDatabase. Все, что вам нужно - TDataSource, TTable и компоненты для работы с базами данных. [001306]


Как при вводе информации в БД автоматически вставлять SEQUENCE?

Nomadic отвечает:

Если добавление через оператор INSERT ( в TQuery), то прямо там пишешь, как в плюсе ("... Values (My_seq.nextval, ...").

Если добавление идет через TQuery c RequestLive=true, то в BeforeInsert сделай запрос через TQuery (select myseq.nextval from dual) и заноси значение в свое поле. [001311]


Delphi 1

Помещение переменной в Memo-поле

Если я правильно понял ваш вопрос, вам нужно сделать приблизительно так (для ПОЛУЧЕНИЯ данных):

Memos := TStringList.Create;
Memos.Assign(Table1Memo);
yourvariable_0 := Memos[0];
yourvariable_1 := Memos[1];
.........................
yourvariable_n := Memos[n];
Memos.Free;

или так (для УСТАНОВКИ данных):

Memos := TStringList.Create;
Memos.Add(yourvariable_0);
Memos.Add(yourvariable_1);
..........................
Memos.Add(yourvariable_n);
Table1Memo.Assign(Memos);
Memos.Free;

[001325]


Delphi 1

Индикатор прогресса выполнения запроса

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

Если вы используете Paradox или DBase, то, я думаю, для этой цели вы можете воспользоваться функцией DBIRegisterCallback:

>Из руководства пользователя DBE:

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

Лично я никогда этим не пользовался, поэтому на смогу поделиться деталями. [001327]


Delphi 1

Обновление данных БД из модальной формы

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

unit myModalF;

interface
{...}

implementation
{...}

uses
MainForm; {Имя файла родительской формы для вашей модальной формы}

MyModalForm.OnCreate(Sender: TObject);
begin
DBGrid1.DataSource := MyMainForm.DataSource1;
end;

[001337]


Как записать в BLOB-поле большой текст (>255 байт) из Delphi?

Nomadic отвечает:

Можно так -

var
S: TBlobStream;
B: pointer;
c: integer;
...
Table1.Edit;
S := TBlobStream.Create( Table1BlobField as TBlobField, bmWrite ); {кажется, так}
C := S.Write(B, C);
Table1.Post;
S.Destroy;

или так -

var
S: TMemoryStream;
B: pointer;
C: integer;
...
S := TMemoryStream.Create;
...
Table1.Edit;
S.Clear;
S.SetSize(C);
C := S.Write(B,C);
( Table1BlobField as TBlobField ).LoadFromStream( S );
S.Clear;
Table1.Post;
...
S.Destroy;

[001359]


Блокировка таблицы

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

try
Table1.Post;
except
MessageDlg ('Ошибка постинга записи', прочее...
Table1.Cancel;
end;

В противном случае вы не получите ошибку в случае, если текущую запись "рассматривает" другой пользователь (если вы пользуетесь базой данных Paradox, поставляемой с Delphi), если, конечно, вы правильно это установили. Paradox сам создает в сетевом каталоге файл с именем pdxusers.lck, видимый всеми пользователями, так что каждый BDE на каждой локальной машине может запирать запись, таким образом запрещая другим пользователям постить запись до снятия блокировки. Я не знаю, каким образом вы получаете эту ошибку, поэтому существует вероятность того, что я ошибаюсь в своих предположениях. [001368]


Delphi 1

Каким драйвером пользуется TDATABASE?

Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):

var
pDatabase: DBDrsc:
begin

{ pAlias - PChar, содержащий имя псевдонима}
dbiGetDatabaseDesc ( pAlias, @pDatabase ) ;

Для получения дополнительной информации обратитесь к описанию свойства pDatabase.szDbType. [001384]


Как создать новый запрос и скопировать туда точно такие же описания полей?

Nomadic отвечает:

Копируешь FieldDefs.
Проходишь циклом по FieldDefs.Items[ i ].CreateField( Owner ); [001387]


Delphi 1

Запись потока в BLOB-поле

Вся хитрость заключается в использовании StrPcopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen().

Вот пример использования TMemoryStream и записи его в Blob-поле:

var
cString: String;
oMemory: TMemoryStream;
Buffer: PChar;
begin

cString := 'Ну, допустим, хочу эту строку!';

{ СОздаем новый поток памяти }
oMemory := TMemoryStream.Create;

{!! Копируем строку в PChar }
StrPCopy( Buffer, cString );

{ Пишем =буфер= и его размер в поток }
oMemory.Write( Buffer[0], StrLen( Buffer ) );

{Записываем это в поле}
<Blob/Memo/GraphicFieldName>.LoadFromStream( oMemory );

{ Необходимо освободить ресурсы}
oMemory.Free;

end;

[001388]


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

Nomadic отвечает:

Наиболее приемлемым является использование TQuery и Provider.SetParams.

Но также Вы можете сделать это иначе:
Сперва на клиенте Вам нужно считать с сервера только метаданные для набора данных. Это можно сделать, установив PacketRecords в 0, и затем вызвав Open. Затем Вы должны вызвать метод сервера (Вы должны определить этот метод на сервере), который спозиционирует курсор на первую нужную запись. И, наконец, установите PacketRecords в нужное значение, большее нуля, и вызовите GetNextPacket. [001452]


Отследить изменение данных?

Предположим, что пользователь изменил строковое поле в Null. Как тогда я в обработчике OnUpdateData смогу определить, изменилось ли это поле на строку Null, или поле просто не было изменено?

Nomadic отвечает:

Используйте свойство NewValue класса TField при чтении второй записи (той, которая содержит изменения). Если возвращаемое значение (variant) пусто или не назначено, тогда поле не было модифицировано. Здесь немного иллюстрирующего кода:

var
NewVal: Variant;

begin
NewVal := DataSet.FieldByName('MyStrField').NewValue;
if VarIsEmpty(NewVal) then
ShowMessage('Field was not edited')
else if VarIsNull(NewVal) then
ShowMessage('Field was blanked out')
else
ShowMessage('New Field Value: ' + String(NewVal));
end;

Если Вы взглянете на исходники формы RecError (в репозитории), то Вы увидите, как она использует эту информацию для вывода строки '' при показе ошибок синхронизации данных. На сервере Вы добавляете ограничения уровня записи, используя свойство Constraints Вашего TQuery/TTable или ограничения уровня поля, используя постоянные обьекты TField (с помощью FieldsEditor либо на CustomConstraint, либо ImportedConstraint). Если Вы используете ограничения уровня поля, они вступают в силу, когда данныеотправляются в поле (например, когда Вы уходите из органа управления, связанного с этим полем (типа TDBEdit)). [001456]


Как достучаться до методов сервера приложений из TClientDataSet?

Nomadic отвечает:

Вот так:

RemoteServer.AppServer.MyMethod

AppServer - свойство только для чтения, возвращающее интерфейс удаленного сервера, возвращаемый провайдером сервера приложений. Клиентские приложения могут общаться напрямую с сервером приложений через этот интерфейс. [001469]


Я включил dbclient.dll в секцию `additional files` опций распространения по web, но этот файл никогда не загружается на клиента. Как это исправить?

Nomadic отвечает:

Ваш INF-файл должен включать в себя строки наподобие:

[Add.Code]
dbclient.dll=dbclient.dll
[dbclient.dll]
file=http://yoursite.com/dbclient.cab
clsid={9E8D2F81-591C-11D0-BF52-0020AF32BD64}
RegisterServer=yes
FileVersion=4,0,0,36
Замените "yoursite" Вашим HTTP-адресом, где находится cab-файл. FileVersion - это версия файла в Вашем cab-файле (проверьте информацию о версии DBCLIENT, чтобы быть уверенным в соответствии). Убедитесь, что FileVersion относится к версии Вашего DBCLIENT.DLL. Вы можете положить dbclient.dll в cab-файл, используя утилиту CABARC, которую Вы найдете в папке delphi\bin. Примерная команда вызова CABARC может выглядеть примерно так:
CABARC N DBCLIENT.CAB DBCLIENT.DLL
[001473]


Как можно использовать TClientDataSet в локальном приложении с таблицами Paradox, без использования компонент TProvider и TRemoteServer?

Nomadic отвечает:

Вы не сможете отделаться от Провайдера (хотя бросать его на форму/модуль данных не придется), но Вы сможете использовать TClientDataSet в одно-точечном (single-tier) приложении. Для того, чтобы открыть Client DataSet, Вы должны назначить Провайдера Данных вручную.

{ CDS = TClientDataSet }
{ Table1 = TTable }
 CDS.Provider := Table1.Provider;
CDS.Open;

Также Вы должны включить модуль BDEProv в предложение Uses. [001480]


Hе получается открыть таблицу, созданную в InterBase с DEFAULT CHARACTER SET WIN1251. Оно говорит, что `WIN1251 undefined`

Nomadic отвечает:

A: (AA): Ставьте Interbase в каталог с путем, соответствующим DOS-овским соглашениям об именах (8+3). [001502]


Почему при добавлении/изменении записей в некоторых запросах возникает ошибка Cannot modify a read-only dataset?

Nomadic отвечает:

A: Во-первых, должно быть RequestLive := True; во-вторых, чтобы запрос был редактируемым, он должен удовлетворять требованиям, изложенным в помощи при поиске по "live result sets". [001569]


Функции редактора полей во время выполнения программы

Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы?

Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size).

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

procedure SetupFieldsAndOpenDataset(DataSet: TDataSet) ;
var
FieldNum, DefNum: Integer ;
begin
with DataSet do begin
if Active then Close ;
FieldDefs.Update ; {набор данных должен быть закрыт}
{ищем каждое предопределенное TField в DataSet.FieldDefs:}
for FieldNum := FieldCount - 1 downto 0 do
with Fields[FieldNum] do begin
DefNum := FieldDefs.IndexOf(FieldName) ;
if DefNum < 0 then raise Exception.CreateFmt(
'Поле "%s" не найдено в наборе данных "%s"',
[FieldName, Dataset.Name]) ;
{устанавливаем свойство size:}
Size := FieldDefs[DefNum].Size ;
end ;
Open ;
end ;
end ;

- Lindsay Reichmann [001006]


Производная TIntegerField

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

Это то, что вы хотите. Создайте следующий молуль:

MICRON.PAS:

unit micron;

interface

uses DB, DBTables, Classes;

type

TMicronField = class(TIntegerField)
public
function IsValidChar(Ch: Char): Boolean; override;
end;

procedure Register;

implementation

function TMicronField.IsValidChar(Ch: Char): Boolean;
begin
Result := Ch in ['+', '-', '0'..'9','.'];
end;

procedure Register;
begin
RegisterFields([TMicronField]);
end;

end.

Поместите данный модуль в ваш каталог lib и добавьте это поле, используя диалог установки компонент. Затем, используя "DataSet designer", свяжите TMicronField с нужными вам полями, после чего вы увидите, что список типов полей включает теперь "Micron". (для отображения полей на новый тип поля, сначала вам необходимо удалить все TIntegerFields).

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

- Mark Edington [001015]


Delphi 1

Создание новой таблицы на основе структуры другой таблицы

На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:

property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;

Как вы можете видеть, у него есть метод write. Следовательно, код:

Destination.FieldDefs := Source.FieldDefs;

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

Destination.SetFieldDefs(Source.FieldDefs);

(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)

Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:

property IndexDefs: TIndexDefs read FIndexDefs;

В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:

Source.IndexDefs.Update;
Destination.IndexDefs.Assign(Source.IndexDefs);

Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.

Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.

Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа "List Index Out Of Bounds" (или что-то типа этого). Например, так:

if Source.IndexDefs.Count > 0 then...

Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия. [001235]


Delphi 1

Создание уникального ID для новой записи

Существует несколько способов задавать в таблице уникальный ID.

  1. Вы можете использовать поле с автоприращением

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

  2. Вы можете использовать ID-таблицу

    Если у вас имеется приложение, где нескольким таблицам необходимы уникальные ID, создайте ID-таблицу с двумя полями:

    Table Name A (первичный ключ)
Last Id N
    В методе BeforePost таблицы, которой необходим уникальный ID, делайте примерно так:

    TableBeforePost(Sender: TObject)
    var
    Id: Integer;
    begin
    with TTable(Sender) do
    begin
    {проверяем, существует ли ID для этой записи}
    if Field[0].AsInteger=0  then
    begin
    {ищем имя таблицы в ID-Таблице}
    IDTable.FindKey[Name]
    {извлекаем последний Id - подразумеваем блокировку записи}
    Id := IDTable.FieldByName['Last Id'].AsInteger;
    Inc(Id);
    {записываем новый Id в ID-таблицу - подразумеваем разблокировку таблицы}
    IDTable.FieldByName['Last Id'].AsInteger := Id;
    IDTable.Post;
    {записываем извлеченный ID в вашу таблицу}
    Field[0].AsInteger := Id;
    end;
    end;
    end;

    end;

    Если вы поместите этот код в обработчик события таблицы BeforePost, вы убедитесь в том, что все ID будут последовательными (без "дырок"). Недостаток: если пользовать во время попытки добавления новой записи вдруг передумает, вы будете иметь запись с заполненным только полем ID.

    В случае, если вы решили воспользоваться данным способом (последовательные ID), поместите приведенный выше код в обработчик события таблицы OnNewRecord.

  3. Вы можете использовать ID-файл

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

[001254]


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

Delphi в режиме разработки позволяет быстро добавлять и настраивать в вашем проекте компоненты для работы с базами данных, но есть ситуации, когда вам нужно создавать и конфигурировать объекты во время выполнения программы. Например, во время выполнения программы вам может понадобиться добавить колонку с вычисляемым полем (используя алгоритмы пользователя). Поэтому вопрос: как, не используя среды разработки, Инспектора Объектов и редактора TFields, создавать и сконфигурировать TField и другие компоненты для связки данных?

В следующем примере показано динамическое создание TTable, таблицы базы данных в связке с TTable, TFieldDefs, TFields, вычисляемых полей и подключение обработчика для события OnCalc.

Для начала выберите пункт New Application меню File. Будет создан новый проект с пустой формой, на которой мы и будет создавать на лету наши компоненты.

В секцию interface вашего модуля формы добавьте, как показано ниже, объявление обработчика события OnCalcFields и поля TaxAmount. Позже мы создадим TTable и назначим этот обработчик событию TTable OnCalcFields, который позволит при чтении каждой записи вызывать событие OnCalcFields, которое, в свою очередь, выполнит нашу процедуру TaxAmountCalc.

type
TForm1 = class(TForm)
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;

В секции implementation создайте обработчик события OnCalc как показано ниже:

procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] *
(Dataset['TaxRate'] / 100);
end;

Создайте обработчик формы OnCreate как показано ниже (для получения дополнительной информации о создании обработчиков событий обратитесь к Delphi Users Guide, Chapter 4 "Working With Code").

procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin

{ Создаем компонент TTable -- связанная
таблица базы данных будет создана ниже. }
MyTable := TTable.Create(Self);
with MyTable do
begin

{ Определяем основную базу данных и таблицу.
Примечание: Test.DB пока не существует. }
DatabaseName := 'DBDemos';
TableName := 'Test.DB';

{ Назначаем TaxAmountCalc обработчиком события,
чтобы использовать его при наступлении события
OnCalcFields в MyTable. }
OnCalcFields := TaxAmountCalc;

{ Создаем и добавляем определения полей к массиву TTable
FieldDefs, затем создаем TField с использованием
информации из определения поля. }
with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';

{ Создаем вычисляемое TField, назначаем свойства,
и добавляем поле к массиву определений MyTable. }
TaxAmount := TFloatField.Create(MyTable);
with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;

{ Создаем в базе данных новую таблицу,
используя в качестве основы MyTable. }
MyTable.CreateTable;
end;

{ Создаем компонент TDataSource
и назначаем его MyTable. }
MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;

{ Создаем табличную сетку, отображаем
на форме, и назначаем MyDataSource для
получения доступа к данным из MyTable. }
MyGrid := TDBGrid.Create(Self);
with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;

{ Запускаем нашу конструкцию! }
MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;

Ниже приведен полный исходный код проекта:

unit gridcalc;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Grids, DBGrids, ExtCtrls, DBCtrls, DB,
DBTables, StdCtrls;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] *
(Dataset['TaxRate'] / 100);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin
MyTable := TTable.Create(Self);

with MyTable do
begin
DatabaseName := 'DBDemos';
TableName := 'Test.DB';
OnCalcFields := TaxAmountCalc;

with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';
TaxAmount := TFloatField.Create(MyTable);

with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;
MyTable.CreateTable;
end;

MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;
MyGrid := TDBGrid.Create(Self);

with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;

MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;

end.

[001269]


Delphi 1

Проблема с AddIndex

Я использую таблицу paradox на своей локальной машине.

Я использую следующие команды:

Table.DatabaseName := 'ABC';
Table.TableName := 'TEST';
Table.CreateTable;
Table.AddIndex('Primary','ID',[ixPrimary]); (работает как часы)
Table.AddIndex('Number_IDX','NUMBER',[ixUnique]); (здесь я получаю ошибку времени выполнения)

ID - LongInt поле
NUMBER - поле типа char[15] [001321]


Как создать БД в кодировке CP1251?

Nomadic отвечает:

Вот такая конструкция проходит на DB2 2.1.2/NT и UDB5/NT...

CREATE DATABASE Efes2
USING CODESET 1251 TERRITORY RU
COLLATE USING IDENTITY;
[001345]


Delphi 1

Таблицы в памяти

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

ВНИМАНИЕ! ДАННЫЙ КОД НЕ ПРЕДУСМАТРИВАЕТ НИКАКИХ ГАРАНТИЙ!

ИСПОЛЬЗУЙТЕ ЕГО НА СВОЙ СТРАХ И РИСК - ВЫ ЕДИНСТВЕННЫЙ ЧЕЛОВЕК, ОТВЕТСТВЕННЫЙ ЗА ЛЮБОЙ УЩЕРБ, КОТОРЫЙ МОЖЕТ ПОВЛЕЧЬ ЗА СОБОЙ ИСПОЛЬЗОВАНИЕ ДАННОГО КОДА - - Я ВАС ПРЕДУПРЕДИЛ!

Благодарю Steve Garland <72700.2407@compuserve.com> за предоставленную помощь. Он создал свой собственный "in-memory" табличный компонент, который послужил мне толчком для написания сего кода.

InMemory-таблицы являются характеристикой Borland Database Engine (BDE). InMemory-таблицы создаются в RAM и удаляются при их закрытии. Работают они значительно быстрее и очень полезны в случае, если вам нужны быстрые операции в небольших таблицах. Данный пример использует вызов функции BDE DbiCreateInMemoryTable. Данный объект должен работать наподобии простой регулярной таблицы, за исключением того, что InMemory-таблицы не поддерживают некоторые характеристики (типа проверка целостности, вторичные индексы и BLOB-поля), и в настоящее время данный код не содержит механизма обработки ошибок. Вероятно, вы получите ошибку при попытке создания memo-поля. Если у вас есть любые замечания, шлите их по адресу grisha@mira.com.

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type TInMemoryTable = class(TTable)
private
hCursor: hDBICur;
procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
const Name: string; DataType: TFieldType; Size: Word);
function CreateHandle: HDBICur; override;
public
procedure CreateTable;
end;

implementation

{ Эта функция виртуальная, так что я смог перекрыть ее. В оригинальном VCL-коде для TTable эта функция реально открывает таблицу, но, поскольку мы уже имеем дескриптор таблицы, то мы просто возвращаем его }

function TInMemoryTable.CreateHandle;
begin
Result := hCursor;
end;

{ Эта функция получена ее простым копированием из исходного кода VCL. Я должен был это сделать, поскольку это было объявлено в секции private компонента TTable, поэтому отсюда у меня не было к этому досупа. }

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
const Name: string; DataType: TFieldType; Size: Word);
const
TypeMap: array[TFieldType] of Byte = (
fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
with FieldDesc do
begin
AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
iFldType := TypeMap[DataType];
case DataType of
ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
iUnits1 := Size;
ftBCD:
begin
iUnits1 := 32;
iUnits2 := Size;
end;
end;
case DataType of
ftCurrency:
iSubType := fldstMONEY;
ftBlob:
iSubType := fldstBINARY;
ftMemo:
iSubType := fldstMEMO;
ftGraphic:
iSubType := fldstGRAPHIC;
end;
end;
end;

{ Вот кухня, где все это происходит. Я скопировал эту функцию из исходников VCL и затем изменил ее для использования DbiCreateInMemoryTable вместо DbiCreateTable. Поскольку InMemory-таблицы не поддерживают индексы, я удалил весь соответствующий код. }

procedure TInMemoryTable.CreateTable;
var
I: Integer;
pFieldDesc: pFLDDesc;
szTblName: DBITBLNAME;
iFields: Word;
Dogs: pfldDesc;
begin
CheckInactive;
if FieldDefs.Count = 0 then
for I := 0 to FieldCount - 1 do
with Fields[I] do
if not Calculated then
FieldDefs.Add(FieldName, DataType, Size, Required);
pFieldDesc := nil;
SetDBFlag(dbfTable, True);
try
AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
iFields := FieldDefs.Count;
pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
for I := 0 to FieldDefs.Count - 1 do
with FieldDefs[I] do
begin
EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
DataType, Size);
end;
{ тип драйвера nil, т.к. поля логические }
Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
nil, nil, pFieldDesc));
{ здесь hCursor получает свое значение }
Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc,
hCursor));
finally
if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields *
SizeOf(FLDDesc));
SetDBFlag(dbfTable, False);
end;
end;

end.

{Данный код взят из файлов помощи Ллойда!}

[001370]


Delphi 1

FindKey для нескольких полей

with Table1 do
begin
SetKey;
FieldByName('State').AsString := 'CA';
FieldByName('City').AsString := 'Scotts Valley';
GotoKey;
end;

Вы не можете использовать Findkey с файлами DBase более чем для одного поля.

oEmetb.indexName:='PrimaryKey';
if oEmeTb.findkey([prCLient,prDiv,prEme])then

где findkey передаются параметры для Primary Keyfields.

Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.

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

oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo';
if oEmeTb.findkey([123,'A',96])then

[001277]


Поиск существующей записи перед тем, как она будет вставлена

Если вы находитесь в режиме редактирования (Edit) или вставки (Insert), то при изменении режима вы автоматически делаете постинг записи. И, естественно, при наличие дубликата (неуникальности) записи, вы получите ошибку. Способ обойти это - использовать другой компонент TTable, связанный с той же таблицей, и осуществляющий по ней поиск. Этот путь самый простой и эффективный.

Воспользуйтесь двумя компонентами TTable (оба должны указывать на одну и ту же таблицу). Используйте один для поиска, а второй для редактирования.

Ваша "ключевая" таблица BDE будет автоматически генерировать исключения, если пользователь будет пытаться послать созданный им дублирующий ключ. Для установки таблицы используйте Database Desktop.

Создайте на основе поля первичный индекс (Primary Index). Затем создайте какой-то обработчик DB-исключения для нашего "нарушения уникальности".

Моя технология заключается в следующем: в отдельной форме я предлагаю пользователям ввести часть записи, которая должна быть уникальна (обычно одно поле). Затем для проверки существования я делал FindKey. Если он находился, через MessageDlg я информировал пользователя, и возвращал его на форму редактирования, не создавая новой записи. Помните, что если FindKey ничего не находит, dbCursor никуда не перемещается, и закладка не нужна. Если запись найдена, она немедленно будет отображена на форме редактирования для того, чтобы пользователь смог увидеть ее содержимое. В противном случае происходит следующее:

Table.Append;
Table.FieldByName('KeyField').AsString := UserEntry;
{ ... позволяем пользователю редактировать все остальные поля записи ... }
{ в это время кнопка Cancel должна быть активной для того, чтобы
дать возможность пользователю отменить ввод новой записи. }

В моей форме редактирования поле с уникальном ключем выключается (disabled) и показывается с другим цветом. Целостность соблюдена :-). [001296]


Delphi 1

Поиск фраз и записей переменной длины

Для текста переменной длины вы можете использовать DBmemo. Большинство людей это делают сканированием "на лету" (когда оператор постит запрос), но для реального ускорения процесса можно попробовать способ пре-сканирования, который делают "большие мальчики" (операторы больших баз данных):

  1. при внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: "the", "of", "and"])

  2. ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, "hang",46 или "PC",22.

  3. когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, "hang" может возвратить номера записей 11, 46 и 22, тогда как "PC" - записи с номерами 91, 22 и 15.

  4. затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи.

  5. для синонимов определите таблицу синонимов (например, "hang","kaput"), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово.

  6. слова, имеющие общие окончания (например, "hang" и "hanged"), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову "hang" соответствует любое слово, чьи первые 4 буквы равны "hang").

Конечно, есть множестно технических деталей, которые необходимо учесть, например, организация списков, их эффективное управление и объединение. Оптимизация этой характеристики может вам дать очень быстрое время поиска (примером удачный реализаций могут служить двигатели поиска Nexus, Lycos или WebCrawler, обрабатывающие сотни тысяч записей в течение секунды). [001382]


Delphi 1

Текущий номер записи набора данных

{Извлекает физический номер записи xBase. Требует наличие модулей DBITYPES, DBIPROCS,
и DBIERRS в списке используемых модулей. Функция требует на входе один аргумент
типа TTable (например, Table1).}
 function Form1.Recno( oTable: TTable ): Longint;
var
rError: DBIResult;
rRecProp: RECprops;
szErrMsg: DBIMSG;
begin
Result := 0;
try
oTable.UpdateCursorPos;
rError := DbiGetRecord( oTable.Handle, dbiNOLOCK, nil, @rRecProp );
if rError = DBIERR_NONE then
Result := rRecProp.iPhyRecNum
else
case rError of
DBIERR_BOF: Result := 1;
DBIERR_EOF: Result := oTable.RecordCount + 1;
else
begin
DbiGetErrorString( rError, szErrMsg );
ShowMessage( StrPas( szErrMsg ));
end;
end;
except
on E: EDBEngineError do ShowMessage( E.Message );
end;
end;

[001239]


Как открыть индексированную таблицу dBase, если отсутствует файл индекса?

Nomadic советует:

Для dBase-таблицы встроенными средствами ты не перестроишь индекс, если его нет. Для этой цели мне пришлось написать процедуру для физического удаления признака индексации в самом dbf-файле и после её применения добавлять индексы заново.

Для этого в заголовок файла dbf по смещению 28(dec) записываешь 0.

По другому никак не выходит(я долго бился)- вот для Paradox таблиц все Ok.

С помощью BDE Callbacks. Пpимеp для Delphi 2.0, на пеpвом не пpовеpял:

=== Callback.pas ===

unit Callback;

interface

uses BDE, Classes, Forms, DB, DBTables;

type
TForm1 = class(TForm)
Table1: TTable;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
CBack: TBDECallback; // опpеделение BDE CallBack
CBBuf: CBInputDesc; // пpосто буфеp
function CBFunc(CBInfo: Pointer): CBRType; // Callback-функция
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Session.Open; // В это вpемя сессия ещё не откpыта
CBack := TBDECallback.Create( Session {Hапpимеp}, nil, cbINPUTREQ, @CBRegBuf,
SizeOf(CBBuf), CBFunc, False); // Опpеделили Callback
Table1.Open;
//^^^^^^^^^^^ - здесь возможна ошибка с индексом, etc.
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
CBack.Free; // Освобождаем CallBack
end;

function TForm1.CBFunc(CBInfo: Pointer): CBRType;
begin
with PCBInputDesc(CBInfo)^ do
case eCbInputId of
cbiMDXMissing {, cbiDBTMissing - можно ещё и очищать BLOB-поля}:
begin
iSelection := 3; // Hомеp ваpианта ответа (1-й - откpыть только
// для чтения, 2-й - не откpывать, 3-й - отсоединить индекс).
// Возможный источник непpиятностей: а вдpуг в последующих веpсиях
// BDE номеpа будут дpугими?
 Result := cbrCHKINPUT; // Обpабатывать введённый ответ
end;
end;
end;

end.

=== Callback.pas ===

PS: конечно, это лишь пpимеp, делающий минимум необходимого. В pамках данного письма невозможно дать какое-то описание BDE Callbacks. Инфоpмацию я взял из BDE32.HLP, BDE.INT и DB.PAS. В VCL.HLP совсем ничего нет по этому поводу.

Вообще, pуки бы отоpвал тем, кто писал спpавку по Дельфям: я неделю мучался с сабжем, пока случайно не набpёл на Callbacks. [001251]


Delphi 1

Определение удаления записей в .DBF

Взято из "Dtopics Database 1.10 from 3K computer Consultancy":

Dbase в BDE имеет большее количество ситуаций 'особого случая', чем таблицы SQL и Paradox, поскольку данный формат поддерживает выражения в индексах и прочие характеристики, например:

  1. Создание и пересоздание индекса

    - DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }

    - создание индекса (зависит от того, существует ли выражение или нет)

    if (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then
    Table1.AddIndex( cTagName, cTagExp, [ixExpression])  (<- ixExpression - _литерал_)
    else
    Table1.AddIndex( cTagName, cTagExp, []);

  2. Связки Master/Detail в выражениях дочерних индексов

    - вызов процедуры BDE DbiLinkDetailToExp() вместо обычной DbiLinkDetail()

  3. Пакование таблиц

    with Table1 do
    StrPCopy( TName, TableName );
    Result := DBIPackTable( DbHandle, Handle, TName, szDBASE, TRUE );

  4. Задание видимости удаленных записей - вкл/выкл (например, dBase SET DELETED ON/OFF)

    DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue));

  5. Задание частичного/полного соответствия символов - вкл/выкл (например, dBase SET EXACT ON/OFF)

    DbiSetProp( hDBIObj(Table1.Handle), curINEXACTON,   LongInt(bValue));

<------- Конец ---------->

Ну и теперь сами вопросы:

<------- Начало --------->

"Как мне увидеть записи 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
Table.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
Table.Refresh;
Table.EnableControls;
end;
end;

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

Создайте вычисляемое поле, затем в обработчике события таблицы OnCalcField замените его таким образом:

procedure TForm1.Table1CalcFields(DataSet: TDataset);
var
RCProps : RecProps;
Result : DBIResult;
begin
Result := DbiGetRecord(Table1.Handle, dbiNo

Рукописи не горят... [001258]


Определение номера записи в таблице dBASE

Таблицы dBASE применяют довольно статическую систему нумерации записей. Номер записи для данной записи (извините за тавтологию) отражает физическую позицию в табличном файле. Эти номера записей не изменяются вследствие фильтрации, упорядочивания данных или сортировки. К примеру, первая запись, хранящаяся в .DBF файле, будет иметь номер записи 1. Возможно, после некоторого упорядочивания индекса, запись будет последней из 100 записей. В этом случае запись должна оставаться с тем же номером, а не номером 100, отражающим новую позицию в сортированном наборе данных. Это противоречит таблицам Paradox, где соблюдается последовательная нумерация. Последовательная нумерация Paradox похожа на нумерацию записей dBASE, за исключением большей гибкости и отражению в номере записи ее текущей позиции в наборе данных. То есть, запись может не всегда иметь номер, установленный для нее фильтром набора данных, уменьшившим общее число записей, или при активном индексе, из-за чего может измениться отображаемый порядок записи.

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

Существует несколько функций BDE, возвращающих информацию о текущей записи dBASE, например, ее номер. На самом деле, любая функция, заполняющая структуру BDE pRECProps, вполне достаточна. Например, функции BDE DbiGetRecord, DbiGetNextRecord и DbiGetPriorRecord. Естественно, только первая из них реально позволяет получить информацию о текущей записи. Две других перемещают при вводе указатель на запись, подобно методам Next и Prior компонентов TTable и TQuery.

Структура pRECProps состоит из следующих полей:

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

iPhyRecNum: тип LongInt; определяет номер записи; используется, если тип таблицы поддерживает физические номера записи (только dBASE).

bRecChanged: тип Boolean; в настоящее время не используется.

bSeqNumChanged: тип Boolean; в настоящее время не используется.

bDeleteFlag: тип Boolean; указывает на удаленную запись; используется, если тип таблицы поддерживает "мягкое" удаление (только dBASE).

Одна из этих BDE-функций может быть вызвана из вашего приложения для заполнения данной структуры, из которой затем может быть извлечен физический номер записи. Ниже - пример использования для этой цели функции DbiGetRecord.

function RecNo(ATable: TTable): LongInt;
var
R: RECProps;
rslt: DbiResult;
Error: array [0..255] of Char;
begin
ATable.UpdateCursorPos;
rslt := DbiGetRecord(ATable.Handle, dbiNoLock, nil, @R);
if rslt = DBIERR_NONE then
Result := R.iPhyRecNum
else begin
DbiGetErrorString(rslt, Error);
ShowMessage(StrPas(Error));
Result := -1;
end;
end;

Для вызова любой BDE-функции из приложения Delphi, модули-обертки BDE DbiTypes, DbiErrs и DbiProcs должны быть включены в секцию Uses модуля, из которого они будут вызываться (секция Uses здесь не показана). Для того, чтобы сделать функции более транспортабельными, они не имеют прямой ссылки на компонент TTable, но указатель на TTable передается как параметр. Если эта функция используется в модуле, который не ссылается на модули Delphi DB и DBTables, они должны быть добавлены, иначе ссылки на компонент TTable будут недействительными.

Метод TTable UpdateCursorPos вызывается для гарантии синхронизации номера текущей записи в компоненте TTable и связанной с ним таблицы.

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

Если вызов DbiGetRecord был успешным, физический номер записи из поля iPhyRecNum структуры pRECProps сохраняется в переменной Result, которая является возвращаемой функцией величиной. Чтобы указать на то, что функция потерпела неудачу (т.е., вызов фунции DbiGetRecord окончился неудачно), вместо номера записи возвращается отрицательная величина. Значение ее может быть произвольным (отрицательная величина совместимого типа) и отдается на усмотрение программисту. [001262]


Пакование таблиц dBASE II

Упаковка таблиц dBASE требует вызова BDE функции DbiPackTable. Пример ее использования показан ниже, включая проверку на ошибки. Чтобы воспользоваться функцией DbiPackTable, вызывающий модуль должен в своей секции uses иметь модули-обертки BDE DbiTypes, DbiErrs и DbiProcs.

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

Вот сам пример:

procedure TForm1.Button1Click(Sender: TObject);
var
Error: DbiResult;
ErrorMsg: String;
Special: DBIMSG;
begin
table1.Active := False;
try
Table1.Exclusive := True;
Table1.Active := True;
Error := DbiPackTable(Table1.DBHandle, Table1.Handle, nil, szdBASE, True);
Table1.Active := False;
Table1.Exclusive := False;
finally
Table1.Active := True;
end;
case Error of
DBIERR_NONE:
ErrorMsg := 'Успешно';
DBIERR_INVALIDPARAM:
ErrorMsg := 'Указанное имя таблицы или указатель на имя таблицы ' +
'равен NULL';
DBIERR_INVALIDHNDL:
ErrorMsg := 'Указанный дескриптор базы данных или курсора ' +
'неверен или равен NULL';
DBIERR_NOSUCHTABLE:
ErrorMsg := 'Таблица с таким именем не существует';
DBIERR_UNKNOWNTBLTYPE:
ErrorMsg := 'Неизвестный тип таблицы';
DBIERR_NEEDEXCLACCESS:
ErrorMsg := 'Таблица открыта не в эксклюзивном режиме';
else
DbiGetErrorString(Error, Special);
ErrorMsg := '[' + IntToStr(Error) + ']: ' + Special;
end;
MessageDlg(ErrorMsg, mtWarning, [mbOk], 0);
end;

[001308]


Пакование таблиц dBASE III

Для упаковки таблицы dBASE, открытой с помощью TTable, воспользуйтесь функцией BDE DbiPackTable. Для этого достаточно сделать две операции:

  1. Добавьте в секцию uses следующие модули:

    { Для Delphi 1.0: } DBITYPES, DBIPROCS и DBIERRS;
    { Для Delphi 2.0: } BDE;

  2. Затем вызовите BDE функцию DbiPackTable следующим образом:

    Check(DbiPackTable(Table1.DbHandle, Table1.Handle, Nil, szDBASE, TRUE));

Примечания:
  • Таблица должна быть открыта в эксклюзивном режиме.
  • При вызове функций API BDE используйте процедуру Check. Check в случае ошибки при вызове BDE генерирует исключительную ситуацию.
[001310]


Пакование таблиц dBASE IV

Nomadic советует:

Для dBase:

uses
DbiProcs;

with Table do
begin
OldState := Active;
Close;
Exclusive := True;
Open;

DbiPackTable( DBHandle, Handle, nil, nil, True );
{^ здесь можно добавить check()}

Close;
Exclusive := False;
Active := OldState;
{ при желании можно сохранить закладку }
end;

Pavel Kulchenko
(2:465/66)

Пpимеp для Paradox:

Uses BDE; // for D3, для D2 не помню (что-то типа DbiProcs и еще что-то)

// для пpимеpа
tLog : TTable; // таблица, юзающая d:\db\log.db

var
TblDesc: CRTblDesc;
rslt: DBIResult;
Dir: String; //имеется в виду huge string т.е. {$H+}
hDb: hDbiDb;

begin
tLog.Active := False; //деактивиpуем TTable

SetLength( Dir, dbiMaxNameLen + 1 );
DbiGetDirectory( tLog.DBHandle, False, PChar( Dir ) );
SetLength( Dir, StrLen( PChar( Dir ) ) );

DbiOpenDatabase( nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb );

DbiSetDirectory( hDb, PChar( Dir ) );

FillChar( TblDesc, sizeof( CRTblDesc ), 0 );
StrPCopy( TblDesc.szTblName, 'd:\db\log.db' );
// здесь должно быть полное имя файла
//котоpое можно: а) ввести pуками;
//б) вытащить из пpопеpтей таблицы;
//в) вытащить из алиаса;
//г) см. FAQ
 StrCopy( TblDesc.szTblType, szParadox );
//BTW тут может и szDBase стоять

TblDesc.bPack := TRUE;

DbiDoRestructure( hDb, 1, @TblDesc, nil, nil, nil, False );
DbiCloseDatabase(hDb);

end;

// можно еще чеки ввести, но облом :-)

[001355]


Показ удаленных записей в таблице dBASE

В таблицах dBASE записи не удаляются до тех пор, пока таблица не будет упакована. Пока же это не произойдет, удаленные записи остаются в таблице, только имеют при этом флажок "к удалению". Для того, чтобы показать эти существующие, но не отображаемые записи, существует функция ShowDeleted(), которая использует функцию BDE API DbiSetProp(), показывающая записи, помеченные к удалению. При использовании этой функции нет необходимости закрывать и вновь открывать таблицу. ShowDeleted() в качестве параметров передается TTable и логическое значение. Логический параметр указывает на необходимость показа удаленных записей.

Демонстрационный проект:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, DB, DBTables;

type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
DBNavigator1: TDBNavigator;
CheckBox1: TCheckBox;
procedure CheckBox1Click(Sender: TObject);
public
procedure ShowDeleted(Table: TTable; ShowDeleted: Boolean);
end;

var
Form1: TForm1;

implementation

uses DBITYPES, DBIERRS, DBIPROCS;

{$R *.DFM}
procedure TForm1.ShowDeleted(Table: TTable; ShowDeleted: Boolean);
var
rslt: DBIResult;
szErrMsg: DBIMSG;
begin
Table.DisableControls;
try
Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON,
LongInt(ShowDeleted)));
finally
Table.EnableControls;
end;
Table.Refresh;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
ShowDeleted(Table1, CheckBox1.Checked);
end;

end.

[001312]


Delphi 1

Пароль на dBASE-файлы

dBase-файлы не поддерживают пароли. Естественно, вы можете создать свои собственные методы поддержки паролей. Но это будет работать только с вашими приложениями. Боюсь, что при наличии тысяч читателей/конверторов dBase, этот способ не годится. [001314]


Delphi 1

Показ меток 'удаленных' записей в dBASE-файлах

Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:

procedure TForm1.Button1Click(Sender: TObject);
var
B: BOOL;
W: Word;
begin
Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON,
longint(True)));
{ Проверяем, что это работает }
Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B,
sizeof(B), W));
if B = False then
Label2.Caption := 'Не помечена'
else
Label2.Caption := 'Помечена';
end;

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

Table1.UpdateCursorPos;
Check(DbiUndeleteRecord(Table1.Handle));

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

Ну и, наконец, чтобы все работало, поместите модули DBIPROCS и DBITYPES с список USES. [001333]


Как заставить работать DB2 через протокол IPX?

Nomadic отвечает:

Связь Win-клиента c DB2 в сети Netware
Hастройка доступа к DB2

1. Связь с использованием протокола IPX/SPX.

Возможны два варианта доступа:

  • через сервер NETWARE;
  • прямая адресация.
1.1. Конфигурация для доступа через сервер.

Замечание: Проверялся доступ через сервера NW 3.11 и 3.12. Для 4.х нужно еще разобраться.

1.1.1. DB2 Сервер

  • должна быть установлена OS/2 Warp или OS/2 Warp Connect;
  • включена поддержка NETWARE;
  • в CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и перезагрузить систему;
  • создать командный файл DBIPXSET.CMD следующего вида:
    |------------------------------------------------------------------
|db2 update dbm cfg using fileserver  objectname dbserver
|------------------------------------------------------------------
    где - <NWSERVER> - имя сервера;
  • выполнить командный файл DBIPXSET.CMD;
  • перестартовать сервер базы данных;
  • создать командный файл DBIPXREG.CMD следующего вида:
    |----------------------------------------------------------------
|db2 register nwbindery user
|----------------------------------------------------------------
    где - <USERNAME> - имя пользователя, обладающего правами администратора на сервере <NWSERVER> ;
  • выполнить командный файл DBIPXREG.CMD;
  • ответить на запрос пароля.
1.1.2. WINDOWS - клиент
  • установить WINDOWS 3.1 или WfWG 3.11;
  • установить клиента NETWARE от версии 4.х;
  • при установке влючить поддержку WINDOWS;
  • установить клиента DB2 для WINDOWS;
  • используя программу Client Setup описать новый узел - сервер базы данных :
    Name - <любое имя>
Protocol - IPX/SPX
File server - <NWSERVER>
Object name - dbserver
  • описать базу данных и разрешить доступ к ней через ODBC.
1.2. Конфигурация для доступа через прямую адресацию

1.2.1. DB2 Сервер

  • см. п 1.1.1;
  • найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее;
  • записать полученный адрес;
1.2.2. WINDOWS - клиент
  • см. п. 1.1.2. (первые три шага);
  • используя программу Client Setup описать новый узел - сервер базы данных :
    Name - <любое имя>
Protocol - IPX/SPX
File server - *
Object name - <адрес полученный от DB2IPXAD.EXE>
  • описать базу данных и разрешить доступ к ней через ODBC.
[001332]


Почему DB2 ругается на Create Trigger?

Nomadic отвечает:

Я тут писал по поводу того, что у меня не pаботали тpиггеpы. Все дело оказалось в пpавиле написания команды "create trigger". Если все остальные команды коppектно воспpинимаются на любом pегистpе, то эта - только набpанная одними большими буквами. [001389]


Delphi 2

Модуль данных для каждого MDIChild

Когда во время разработки вы устанавливаете "DataSource"-свойство в БД-компонентах для указания на модуль данных, VCL во время выполнения приложения будет пытаться создать связь с существующим TDataModule, основываясь на его свойтсве Name. Так, если вы добавите модуль данных к вашему проекту и переместите его в свойстве проекта из колонки автоматически создаваемых форм в колонку доступных, вы сможете разработать форму, содержащую элементы управления для работы с базами данных, после чего несколькими строчками кода можете создать экземпляр формы, имеющий экземпляр собственного модуля данных.

С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.

unit Childwin;

interface

uses Windows, Classes, Graphics, Forms, Controls,
ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids,
DataM; {!} // Модуль TDataModule1

type
TMDIChild = class(TForm)
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
DBEdit1: TDBEdit;
DBEdit2: TDBEdit;
DBNavigator1: TDBNavigator;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
{!} DM:TDataModule1;
{!} constructor Create(AOwner:TComponent); override;
end;

implementation

{$IFDEF XOXOXOX}  // DataM должен находиться в секции interface. Необходимо для среды
uses DataM;      // времени проектирования. Определение "XOXOXOX" подразумевает,
{$ENDIF}         // что это никогда не будет определено, но чтобы компилятор видел это.

{$R *.DFM}

{!} constructor TMDIChild.Create;
{!} begin
{!}   DM := TDataModule1.Create(Application);
{!}   inherited Create(AOwner);
{!}   DM.Name := '';
{!} end;

procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;

end.

- Pat Ritchey [001014]


Как передать UserName и Password в удаленный модуль данных (remote datamodule)?

Nomadic отвечает:

В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.

Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.

procedure Login(UserName, Password: WideString);
begin
{ DB = TDatabase }

{ Something unique between clients }
 DB.DatabaseName := UserName + 'DB';
DB.Params.Values['USER NAME'] := UserName;
DB.Params.Values['PASSWORD'] := Password;
DB.Open;
end;

После того, как Вы создали этот метод автоматизации, Вы можете вызывать его с помощью:

RemoteServer1.AppServer.Login('USERNAME','PASSWORD');

[001477]


Delphi 2

Byte-поля Paradox

Что за магия при записи в поле Paradox Byte? По этому поводу в документации ничего не сказано.

Есть 2 пути получить доступ к данным в TBytesField.

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

    procedure SetCheckBoxStates;
    var
    CBStates: array[1..13] of Byte;
    begin
    CBStateField.GetData(CBStates);
    { Здесь обрабатываем данные... }
    end;

    Для записи значений вы должны использовать SetData.

  2. Используйте свойство Value, возвращающее вариантный массив байт (variant array of bytes):

    procedure SetCheckBoxStates;
    var
    CBStates: Variant;
    begin
    CBStates := CBStateField.Value;
    { Здесь обрабатываем данные... }
    end;

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

- Mark Edington [001018]


Доступ к таблицам Paradox на CD или c флагом только для чтения

Тема: Доступ к таблицам Paradox на CD или на дисках c флагом только для чтения

Данный совет поможет вам разобраться в таком вопросе, как доступ к таблицам Paradox, расположенным на CD-ROM или диске, имеющем флаг "только для чтения".

Механиз блокирования файлов Paradox требует наличие файла PDOXUSRS.LCK, осуществляющий логику работы блокировки. Данный файл обычно создается во время выполнения приложения и располагается в том же каталоге, где и таблицы. Тем не менее, в случае с CD-ROM, во время выполнения программы нет никакой возможности создать на нем описанный выше файл. Решение простое: мы создаем этот файл и помещаем его на CD-ROM во время его (CD) создания. Следующая простейшая программка позволит создать вам файл PDOXUSRS.LCK и поместить его в образ компакта для его последующего копирования на CD-ROM:

  1. Стартуйте пустой проект и добавьте на форму следующие компоненты: TEdit, TButton и TDatabase.
  2. В обработчике кнопки OnClick используйте следующий код:

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if ChkPath then
    Check(DbiAcqPersistTableLock(Database1.Handle, 'PARADOX.DRO','PARADOX'));
    end;

  3. Функция ChkPath является методом, определенным пользователем для формы. Она просто проверяет путь, введенный пользователем в поле редактирования и убеждается, что он существует. Вот функция:

    function TForm1.ChkPath : Boolean;
    var
    s : array[0..100] of char;
    begin
    If DirectoryExists(Edit1.Text) then begin
    DataBase1.DatabaseName:= 'TempDB';
    DataBase1.DriverName:= 'Standard';
    DataBase1.LoginPrompt:= false;
    DataBase1.Connected := False;
    DataBase1.Params.Add('Path=' + Edit1.Text);
    DataBase1.Connected := TRUE;
    Result := TRUE;
    end
    else begin
    StrPCopy(s,'Каталог : ' + Edit1.text + ' не найден');
    Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
    Result := FALSE;
    end;
    end;

    { Примечание: Не забудьте добавить объявление функции в секцию public формы.}

  4. Перед компиляцией необходимо вспомнить еще об одной вещи: в список Uses нужно добавить следующие модули:
      Delphi 1.0: FileCtrl, DbiProcs, DbiTypes, DbiErrs.
  Delphi 2.0: FileCtrl , BDE
    После компиляции и выполнения, программа создаст два файла в определенном вами каталоге. Создаваемые два файла: PDOXUSRS.LCK и PARADOX.LCK.

    Примечание: Файл PARADOX.LCK необходим только для доступа к таблицам Paradox for DOS, так что вы можете его удалить.

  5. Вам осталась сделать только одну последнюю вещь: скопировать оставшийся файл (PDOXUSRS.LCK) в образ CD-ROM. Естественно, ваши таблицы будут только для чтения.

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

    Вот окончательная версия кода:

    unit Unit1;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB, StdCtrls, FileCtrl,

    {$IFDEF WIN32}
    BDE;
    {$ELSE}
    DbiProcs, DbiTypes, DbiErrs;
    {$ENDIF }

    type
    TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    Database1: TDatabase;
    procedure Button1Click(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    function ChkPath : Boolean;
    end;

    var
    Form1: TForm1;

    implementation

    {$R *.DFM}

    function TForm1.ChkPath : Boolean;
    var
    s : array[0..100] of char;
    begin
    If DirectoryExists(Edit1.Text) then begin
    DataBase1.DatabaseName:= 'TempDB';
    DataBase1.DriverName:= 'Standard';
    DataBase1.LoginPrompt:= false;
    DataBase1.Connected := False;
    DataBase1.Params.Add('Path=' + Edit1.Text);
    DataBase1.Connected := TRUE;
    Result := TRUE;
    end
    else begin
    StrPCopy(s,'Каталог : ' + Edit1.text + ' не найден');
    Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
    Result := FALSE;
    end;
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if ChkPath then
    Check(DbiAcqPersistTableLock(Database1.Handle, 'PARADOX.DRO','PARADOX'));
    end;

    end.

[001031]


Delphi 1

Нечувствительный к регистру поиск в первичном индексе Paradox

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


Delphi 1

Создание таблицы Paradox

Вот маленький кусочек кода для создания таблицы Paradox:

with TTable.create(self) do begin
DatabaseName := 'C:\temp';
TableName := 'FOO';
TableType := ttParadox;
with FieldDefs do Begin
Add('Age', ftInteger, 0, True);
Add('Name', ftString, 25, False);
Add('Weight', ftFloat, 0, False);
End;
IndexDefs.Add('MainIndex','IntField', [ixPrimary, ixUnique]);
CreateTable;
End;

[001233]


DBEdit и реальные значения

При работе с реальными числами, хранимые в таблице Paradox, вы уверены в том, что вы используете тип Real как тип ваших данных? Если так, то попробуйте использовать тип Double. Double - 8-байтовое (64-битное) реальное число, которое нормально работает с BDE, тогда как Real - 6-байтовая версия и подходит только для Delphi и BP. Или попробуйте использовать Extended, занимающий 10 байтов. [001243]


Пара строк

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

Nomadic отвечает:

В Парадоксе первичный индекс всегда CaseSensitive. [001263]


Как сменить пароль (master password) для таблицы Paradox?

Nomadic отвечает:

Пожалуйста:

var
db : TDatabase;
Desc : CRTblDesc;
begin
db := PriceTable.OpenDatabase;
FillChar( Desc, SizeOf( Desc ), #0 );
StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) );
StrCopy( Desc.szTblType, szParadox );
StrCopy( Desc.szPassword, 'password' );
Desc.bProtected := TRUE;
Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) );
end;

[001292]


Что нужно сделать для нормальной работы в одноранговой сети с базами Paradox?

Nomadic отвечает:

BDE Config/Admin - нa вклaдке System устaнови LOCAL SHARE в TRUE!

Здесь комментарий -

В Help параметр LOCAL SHARE описан как:

AA> === Cut ===
AA> The ability to share access to local data between an active BDE
AA> application and an active non-BDE application. Set to TRUE if you need to
AA> work with the same files through both a BDE and a non-BDE application at
AA> the same time. (It is not necessary to set LOCAL SHARE to TRUE if you do
AA> not need to have both applications open at the same time.) Default: FALSE.
AA> === Cut ===
Дaк читaл я вышеизложенное, и рaсценивaю его кaк тумaнопускaтельство. А подозревaю, что просто у BDE для скорости есть свой внутренний кэш (или, может, мехaнизм блокировок в пaмяти), и для двух приложений нa одном компьютере оно всё делaет хорошо, a вот если приложение нaходится нa другом компьютере (и лезет в БД через другую копию BDE), то у него есть доступ только к фaйлaм нa диске (кaк и у non-BDE application).

Скорее всего, борлaнд отключaет эти хитрости у сетевых дисков. Hо для локaльного дискa, который рaсшaрен по сети, он этого, похоже, не сделaл :(

И BDE нa фaйл-сервере не зaботится о прaвильных индексaх и блокировкaх нa диске (т.е. не ожидaет, что кто-то мог испрaвить индекс, покa оно ворон считaло).

А этa устaновкa зaстaвляет его рaботaть по стaрым пaрaдоховым соглaшениям.

Что и требовaлось.

PS. Инaче говоря, следует считaть, что network is non-BDE application, и тогдa это не есть бaгa :) [001322]


Delphi 1

Переиндексирование файлов Paradox в пределах моей программы

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

...сейчая я пишу небольшое приложение, которое может оказаться полезным для восстановления "разбитых" таблиц. Аллен, я пошлю тебе полный список шагов, как только смогу перевести их (это писал итальянец, я же только перевожу это), но уже сейчас я могу сказать как это проблему я решил для себя. Один из наших клиентов всегда разбивал таблицы paradox, поскольку они у него всегда были очень большими (в Blob-полях хранились WAV-файлы - оцифрованный голос). Решение заключалось в создании маленьких таблиц, включенных в отношение справочной целостности, и загрузки больших blob-полей в эти отдельные таблицы. Ненужно никаких BDE функций, единственное условие - вы не должны вручную удалять индексные файлы (все .x00, .y01 и т.д., они все имеют маску .x?? и .y??, не трогайте других файлов!), в противном случае вы НЕ СМОЖЕТЕ ОТКРЫТЬ ТАБЛИЦУ, даже с помощью DBD!
...затем я вручную восстанавливал все индексы (затем я что-то забыл, и приложение вылетело с ошибкой...). Если приложение, которое я тебе пришлю, не заработает, я думаю единственным решением будет физическое уничтожение индексов и пересоздание их с помощью соответствующих вызовов BDE. [001329]


Письмо от читателя

После работы программы не сохраняются изменения в базе Paradox

Nomadic отвечает:

A: Где-нибудь при закрытии главной формы выполните нижеследующие куски кода:

Для Delphi 3: Table.FlushBuffers при открытой таблице.

   Для прочих: Table.Open; Check(dbiSaveChanges(Table.Handle));
Table.Close;

[001565]


Письмо от читателя

Как мне упаковать Paradox или DBF таблицу?

Nomadic отвечает:

A: Воспользоваться функцией PackTable из rxLib.

Для перегенерации индексов:

Table1.Exclusive := True;
Table1.Open;
Check(dbiRegenIndexes(Table1.Handle));       //   Uses bde;

[001567]


Помещение Memo-файла с ASCII-разделителем в Memo-поле таблицы

Вам нужно использовать процедуру getTextBuf. Вот пример из электронной справки:

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

procedure TForm1.Button1Click(Sender: TObject);
var
Buffer: PChar;
Size: Byte;
begin
Size := Edit1.GetTextLen;       {Получаем длину строки в Edit1}
Inc(Size);                      {Добавляем место для терминирующего нуля}
GetMem(Buffer, Size);           {Создаем динамическую переменную Buffer}
Edit1.GetTextBuf(Buffer,Size);  {Помещаем Edit1.Text в Buffer}
Edit2.Text := StrPas(Buffer);   {Преобразуем Buffer в строку паскалевского типа}
FreeMem(Buffer, Size);          {Освобождаем память, распрелеленную для Buffer}
end;

[001214]


Пара строк

Почему не всегда верно обновляются IndexDefs по Update?

Nomadic отвечает:

Ошибка в VCL.
А помогает добавление fUpdated:=false; в теле процедуры TIndexDefs.Update.
Или убиением владельца через Free, и пересозданием. [001234]


Delphi 1

БД-дерево взаимоотношений

Все это я делал раньше. Я не могу вам все это показать на развернутом примере, но я дам вам идею как сделать это. Вы должны иметь таблицу, осуществляющую взаимоотношение между людьми. Если на Peter работают Jane и Simon, вы должны иметь таблицу (RELATION) с этими двумя записями.

Master    Slave  ------- имена полей
Peter     Jane
Peter     Simon
Если George и Elisa работают на Jane, то таблица становится такой:
Master    Slave  ------- имена полей
Peter     Jane
Peter     Simon
Jane      George
Jane      Elisa
и так далее.

Если в таблице RELATION необходимо создать дерево, начинающееся на Peter, то нужно добавить к дереву главный узел (запись), где Master = Peter. Затем каждая дочерняя запись располагается ниже записи Master = Peter. После добавления дочерней записи вы сразу увидите, если ребенок имеет собственного ребенка. Ребенок становится теперь, вероятно, отцом, поэтому вы должны позиционировать таблицу RELATION к первой записи, где Master = child, и так далее, рекурсивно. Такой способ гарантирует построение правильного дерева.

Пример:

AddFather('Peter')
AddChild('Peter',1)

Procedure AddFather(Name: String)
Begin
Tree.Add(Name);
End;

Procedure AddChildr(Name: String, Index:Integer)
Begin
Relation.FindKey([Name])
while RelationMaster.AsString = Name do
Begin
Tree.AddChild(Index,RelationSlave.AsString);
AddChild(RelationSlave.AsString,Tree.ItemsCount);
Relation.Next;
End;
End;

По-моему, ошибок нет. [001241]


Delphi 1

DBGrid и Memo-поля

В обработчик события GetText TMemoField поместите следующую строку:

Text := GrabMemoAsString(TMemoField(Sender));

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

function GrabMemoAsString(TheField : TMemoField): String;
begin
if TheField.IsNull then
Result := '' else
with TBlobStream.Create(TheField, bmRead) do
begin
if Size >= 255 then
begin
Read(Result[1], 255);
Result[0] := #255;
end else
begin
Read(Result[1], Size);
Result[0] := Chr(Size);
end;
Free;
while Pos(#10, Result) > 0 do
Result[Pos(#10, Result)] := ' ';
while Pos(#13, Result) > 0 do
Result[Pos(#13, Result)] := ' ';
end;
end;

[001245]


Delphi 1

Убывающий индекс

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

Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);

[001256]


Как работать из Delphi напрямую с MS ADO (Microsoft Active Data Objects)?

Nomadic отвечает:

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

var
OptionalParam: OleVariant;
VarData: PVarData;
begin
OptionalParam := DISP_E_PARAMNOTFOUND;
VarData := @OptionalParam;
VarData^.VType := varError;

после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.

Далее, самый приятный способ получения Result sets:

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

var
MyConn: _Connection;
MyComm: _Command;
MyRecSet: _Recordset;
prm1: _Parameter;
begin
MyConn := CoConnection.Create;
MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;'; MyConn.Open( '', '', '', -1 );
MyCommand := CoCommand.Create;
MyCommand.ActiveConnection := MyConn;
MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'
Prm1 := MyCommand.CreateParameter( 'Id', adInteger.adParamInput, -1, <value> );
MyCommand.AppendParameter( Prm1 );
MyRecSet := CoRecordSet.Create;
MyRecSet.Open( MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText );

... теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.

Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь.

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

Ну и еще можно использовать для доступа к данным всяких там "нестандартных" баз типа MS Index Server или MS Active Directory Services.

В Delphi (как минимум в 4 версии) существует "константа" EmptyParam, которую можно подставлять в качестве пустого параметра. [001259]


Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?

Nomadic отвечает:

"Засунуть" длинную строку можно было и раньше, если написать редактируемый запрос, и воспользоваться операциями Insert/Edit.

Однако это не относится к хранимым процедурам.

В Delphi 3.0 появился новый тип параметра (TBlobField вроде) и соответственно его поддержка в BDE.

Если просто взять BDE 4.01 и выше, то работать все-равно не будет - нужна соотв. версия VCL (из Delphi 3.0 или выше). [001261]


Delphi 1

Дублирование набора записей

Вы можете воспользоваться вторым объектом TTable, подключенным к той же таблице, или можете вызвать метод объект TTable DisableControls, сделать изменения, и вызвать EnableControls. Для сохранения той же позиции вы можете попробовать воспользоваться закладкой. Например, так:

procedure TMyForm.MakeChanges;
var
aBookmark: TBookmark;
begin
Table1.DisableControls;
aBookmark := Table.GetBookmark;
try
{ваш код}
finally
Table1.GotoBookmark(aBookmark);
Table1.FreeBookmark(aBookmark);
Table1.EnableControls;
end;
end;

[001267]


Как программно изменить LangDriver для таблиц dBase и Paradox?

Nomadic отвечает:

Откpываешь help и смотpишь:

.......
var List:TStrings;
.......
BEGIN
.......
List.Add ( 'LANGDRIVER=db866ru0 ');
.......
Session.ModifyDriver( 'DBASE', List );
.......
END;

Это действие я пpовожy пеpед откpытием таблицы

Ivan Sboev
(2:5049/36.15)

Это о "русификации" таблицы. В таблицах dBase и Paradox имеется байт, который определяет CodePage содержимого таблицы. Раньше он не использовался и был зарезервирован. Тебе нужно его правильно установить. Это делается через DBD Restructure table. Если хочешь программно, можешь воспользоваться следующей процедурой:

uses DbiTypes, DbiProcs, DbiErrs, DB, WinProcs, SysUtils;

procedure ChangeLangDriver( DatabaseName, TableName, LDName: string );
var
TblExt: string;
Database: TDatabase;
TblDesc: CRTblDesc;
OptDesc: FLDDesc;
OptData: array [0..250] of Char;
Cur: hDBICur;
Rec: CFGDesc;
begin
if ( TableName='' ) or ( LDName='' ) then
raise Exception.Create( 'Unknown TableName or LDName' );
Database:=Session.OpenDatabase( DatabaseName );
try
if Database.IsSQLBased then raise Exception.Create( 'Function ChangeLangDriver working only with dBase or Paradox tables' );
FillChar( OptDesc, SizeOf( OptDesc ), #0 );
FillChar( TblDesc, SizeOf( TblDesc ), #0 );
StrCopy( OptDesc.szName, 'LANGDRIVER' );
OptDesc.iLen := Length( LDName ) + 1;
with TblDesc do
begin
StrPCopy( szTblName, TableName );
TblExt := UpperCase( ExtractFileExt( TableName ) );
if TblExt = 'DBF' then StrCopy( szTblType, szDbase )
else if TblExt = '.DB' then StrCopy( szTblType, szParadox )
else
begin
AnsiToOEM( StrPCopy( OptData, DatabaseName ), OptData );
if DbiOpenCfgInfoList( nil, dbiREADONLY, cfgPersistent,
StrPCopy( OptData, '\DATABASES\' + StrPas( OptData ) + '\DB INFO\' )
Cur ) <> DBIERR_NONE
then
raise Exception.Create( 'Unknown table type');
try
while DbiGetNextRecord( Cur, dbiNOLOCK, @Rec, nil ) <> DBIERR_EOF do
if StrComp( Rec.szNodeName, 'DEFAULT DRIVER' ) = 0 then
begin
StrCopy( szTblType, Rec.szValue );
Break;
end;
finally
 Check( DbiCloseCursor( Cur ) );
end;
end;
iOptParams := 1;
pfldOptParams := @OptDesc;
pOptData := @OptData;
end;
StrPCopy( OptData, LDName );
Check( DbiDoRestructure( Database.Handle, 1, @TblDesc, nil,
nil, nil, False ) );
finally
Session.CloseDatabase( Database );
end;
end;

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

ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE', 'ancyrr' );
ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE.DB', 'ancyrr' );
ChangeLangDriver( 'C:\DELPHI\DEMOS\DATA', 'CLIENTS.DBF', 'db866ru0' );

LDName:
для D1 - имя .LD файла в каталоге IDAPI\LANGDRV;
для D2 и CB - из BDECFG32.HLP поле Short name в табличке по указателю language drivers, dBASE или поле Internal в табличке по указателю language drivers, Paradox;
для D3 и выше - не знаю так как у меня её нет, но думаю, что также, как и в D2. [001270]


Существует ли средство для вывода определения структуры таблицы?

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

Nomadic отвечает:

Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC.

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

CONNECT TO SAMPLE USER xxx USING yyy
DB2LOOK -d SAMPLE -u xxx -e -t employee
Вывод может быть перенаправлен в файл. Полный синтаксис выдаётся по команде:
DB2LOOK ?
[001276]


У меня есть текстовые файлы, которые я хочу использовать в запросах к DB2, но не хочу создавать из них постоянные таблицы в базе. Что делать?

Nomadic отвечает:

Можно воспользоваться табличными функциями (Table Functions). Они позволяют использовать файлы как таблицы. Примеры приведены в руководстве "Embedded SQL Programming Guide". [001278]


Список структуры полей таблицы

В данном проекте создается список структуры полей соответствующей таблицы, с использованием массивов Fields и IndexDefs, который затем отображается в компоненте ListBox. Демонстрационный проект (dbbrowsr.dpr) решает эту задачу несколько иначе. Вы можете сравнить две версии этого кода.

Примечание: Данный код работает только в 16-битной среде.

procedure TForm1.Button1Click(Sender: TObject); const
MyFielddefs: array[ftUnknown..ftGraphic] of string [8] =
('Unknown', 'String', 'Smallint', 'Integer', 'Word',
'Boolean', 'Float', 'Currency', 'BCD', 'Date',
'Time', 'DateTime', 'Bytes', 'VarBytes', 'Blob',
'Memo', 'Graphic');

var
i, Indx: integer;
Definition: string;
begin
for i := 0 to Table1.FieldCount - 1 do begin
Definition := Table1.Fields[i].DisplayLabel;
Definition := Definition + ' ' +
MyFieldDefs[Table1.Fields[i].DataType];
Table1.IndexDefs.Update;
if Table1.Fields[i].IsIndexField then begin
Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
if Indx > -1 then
if ixPrimary in Table1.IndexDefs[Indx].Options then
Definition := Definition + ' (Первичный)';
end;
Listbox1.Items.Add(Definition);
end;
end;

Приведенная выше версия не работает в 32-битной среде, поскольку в ней присутствуют дополнительные типы полей. Вот версия, которая работает в 32-битной среде:

procedure TForm1.Button1Click(Sender: TObject);
const
MyFielddefs: array[ftUnknown..ftTypedBinary] of string [11] =
('Unknown', 'String', 'Smallint', 'Integer',
'Word', 'Boolean', 'Float', 'Currency', 'BCD',
'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes',
'AutoInc', 'Blob', 'Memo', 'Graphic', 'FmtMemo',
'ParadoxOle', 'DBaseOle', 'TypedBinary');

var
i, Indx: integer;
Definition: string;
begin
for i := 0 to Table1.FieldCount - 1 do begin
Definition := Table1.Fields[i].DisplayLabel;
Definition := Definition + ' ' +
MyFieldDefs[Table1.Fields[i].DataType];
Table1.IndexDefs.Update;
if Table1.Fields[i].IsIndexField then begin
Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
if Indx > -1 then
if ixPrimary in Table1.IndexDefs[Indx].Options then
Definition := Definition + ' (Первичный)';
end;
Listbox1.Items.Add(Definition);
end;
end;

[001293]


Delphi 1

Создание индексного файла из Delphi

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

Table1.AddIndex('Articles','Title', []) ;

создаст индексный файл с именем ARTICLES с использованием поля TITLE в качестве индексного ключа. При создании вы можете воспользоваться различными индексными опциями (например, уникальность, необслуживаемый и пр.) -- для получения дополнительной информации обратитесь к электронной справке по Delphi. ПРИМЕЧАНИЕ: Ваша таблица должна быть открыта исключительно для того, чтобы только воспользоваться методом AddIndex.

Поддержка/обновление индексного файла, если только при создании вы не выставили флаг "необслуживаемый", происходит автоматически. [001298]


Контекстное меню на основе базы данных

var m:TMenuItem;
navidummy:TComponent;
..........................................................
procedure  TMyForm.CreatePopUpMM(Sender: TObject);
begin
Navidummy.free;
Navidummy:=TComponent.create(self);

While not NaviT.EOF do
begin
m := TMenuItem.create(navidummy);
II:=II+1;
with m do
begin
name :='MM'+IntToStr(II);
caption := NaviT.Fieldbyname('MyWHAT').AsString ;
tag := NaviT.Fieldbyname('MyTAG').AsInteger;
visible:=True;
OnClick:= NaviExec ;
end;
MyMenuItem.add(m);
NaviT.Next;
end;
NaviT.Close;

end;

procedure TMyForm.NaviExec(Sender:TObject);
begin
What.text := (Sender as TMenuItem).Caption; { Здесь я получаю то, что хочу ! }
Key:= (Sender as TMenuItem).Tag ;

end;

[001318]


Delphi 1

Корректное закрытие базы данных приложением Delphi

Очень интересный и полезный вопрос!! Я сам так с ним до конца и не разобрался! Но я попробую систематизировать события, происходящие при запросе на завершение работы Windows:

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

    Если при этом хотя бы одно из приложений ответит отрицательно, Windows прерывает процесс завершения работы.

  2. Delphi перехватывает это сообщение, и, в свою очередь, вызывает метод TForm.CloseQuery, (в главной форме, естественно), который генерирует событие OnCloseQuery, в обработчике которого можно указать на неготовность завершения приложения и отмены завершения работы Windows.

  3. Если я правильно понимаю, если ваше приложение "не мешает" Windows завершить свою работу, Windows нормально НЕ завершает работу приложения, поскольку для этого нет необходимости, не нужно освобождать память, ресурсы и пр. Так, если это утверждение верно (это легко можно проверить, но я слишком ленив сейчас), то событие OnCloseQuery - ваш единственный шанс сохранения данных на диске. Я не думаю что эта логика слишком плоха, просто это одна из тех причуд Windows, которую нужно знать и пользоваться ею. Что может произойти в описанном выше сценарии: редактируемая в настоящий момент запись не будет отправлена (Post) в базу данных, но та же самая вещь может случиться и при нормальном завершении приложения.

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

[001323]


Delphi 1

Изменение свойств базы данных во время выполнения приложения

Свойство DatabaseName тесно связано с:

  • каталогом, где расположены ваши табличные файлы.
  • BDE-псевдоним вашей базы данных.
  • DatabaseName вашего компонента TDatabase, если вы имеете его.
Выводы? [001348]


Delphi 3

Как мне задать выражение по умолчанию для объекта TField?

Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:

MyField.DefaultExpression := 'MyValue';

то это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:

MyField.DefaultExpression := '''MyValue''';

В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки). [001352]


После того, как я использовал правый щелчок мыши для создания функции-провайдера, как мне снова выполнить команду контекстного меню `Export from Table`?

Nomadic отвечает:

Как только Вы экспортировали интерфейс провайдера, эта команда контекстного меню перестает быть видимой. Чтобы снова включить ее, Вы должны удалить ассоциированное свойство в Редакторе Библиотеки Типов, и затем нажать кнопку обновления информации в Редакторе Библиотеки Типов (Type Library Editor's Refresh button). Вы могли бы также удалить точку вхождения "Get_XXX" в исходном тексте RemoteDataModule. [001431]


Как работать с новыми, своими интерфейсами в RemoteDataModule?

Nomadic отвечает:

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

(IDispatch(RemoteServer.AppServer) as IAnother)

Необходимо заметить, что это будет работать только, если Вы используете DCOM как транспорт. [001482]


Database Desktop показывает содержимое таблиц шрифтом без русских букв

Nomadic отвечает:

A: Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию

[Properties]
SystemFont=Arial Cyr
Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать. Впрочем, для просмотра таблиц все равно можно порекомендовать rx Database Explorer -- у него это получается очень хорошо.

Ребят, я давно делаю под HТ (под 95 не знаю, не пpобовал) такyю вещь:

      [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage]
      "1252"="c_1251.nls"
[001500]


SQL Explorer & Drag-n-Drop

Васильев Николай делится своим опытом:

Чтобы какую-либо таблицу, просматриваемую в SQL Explorer, на Delphi-форме, необходимо применить простой drag&drop: зацепить мышью заголовок таблицы в окне навигации SQL Explorer'а и перетащить его на форму в IDE Delphi. Автоматически на форме будет создано 3 компонента типов TTable, TDataSource, TDBGrid с настроенными соответствующим образом свойствами. [001633]


Delphi 1

Перехват исключений базы данных

Try
Tabl.Post;
Except
Begin
On EDatabaseError do ShowMessage('Не могу отправить данные (выполнить Post)');
(Sender AS TDBEdit).SetFocus;
End; {Begin}
End, {Try}

Я осуществляю синтаксический разбор Error и вновь генерирую исключение (передаю по иерархии следующему обработчику объектов исключительных ситуаций), если я больше не хочу иметь с ним дела. Если использовать:

On E : EDatabaseError do...

то можно получить значение E.Error. Реально, имя свойства с текстом ошибки должно быть похоже на что-то типа E.Message (уточните в электронной справке).

On EDatabaseError do begin
ShowMessage('Не могу отправить данные');
Edit1.setFocus;
end;

[001672]


Delphi 1

BLOBFIELD как BITMAP

Сохраняем Bitmap в поле dbase с именем Icon. Icon представляет собой двоичное Blob-поле.

procedure ....
var IconStream : TMemoryStream;
..
..
 begin
.
.
IconStream := TMemoryStream.Create;
Image1.picture.icon.savetostream(IconStream);
(Table1.fieldbyname('Icon') as TBlobField).LoadFromStream(IconStream);
Table1.post;
IconStream.Free;
.
.
 end;

** Читаем Bitmap в Timage из поля dbase с именем Icon.

procedure .....
var IconStream : TMemoryStream;
..
..
 begin
.
.
IconStream := TMemoryStream.Create;
(Table1.fieldbyname('Icon') as TBlobField).SaveToStream(IconStream);
{что бы что-нибудь записать, необходимо установить позицию потока в ноль!}
IconStream.Position := 0;
appointment.iconimage.picture.icon.loadfromstream(iconstream);
IconStream.Free;
end;

Надеюсь это поможет, поскольку найти информацию в справочной системе по этой теме практически невозможно. Чтобы сделать это, я перепробовал множество способов. Я пробовал использовать TBlobField и TBlobStream, но они не смогли мне помочь (может быть из-за убогой документации borland?). [001802]


FAQ по InterBase

Ответы на наиболее часто задаваемые вопросы по InterBase (09/27/1996)

Если вы имеете дополнения, исправления или пожелания, шлите мне письма по адресу rlove@pobox.com.

Текущая версия данного FAQ'а доступна по адресу http://www.xmission.com/~uldata/ib/faq.txt.

Авторские права: 1996 Robert J. Love
Данный FAQ свободен для копирования, распространения и изменения формата.

Многие из этих вопросов и ответов взяты непосредственно из документов Borland. Авторские права таких ответов остаются у Borland.

Авторские права: Borland International, Inc.
-----------------------------------------------

Вопросы

1.  Что мне необходимо для распространения InterBase/Delphi приложения,
    созданного для нашего InterBase сервера?
2.  Что мне необходимо для распространения InterBase/Delphi приложения,
    созданного дла работы с Local InterBase?
3.  Что юридически необходимо для распространения Local InterBase Server
    (LIBS)?
4.  Я не могу подключить мои 32-битные приложения к моему серверу Novel...
5.  Мое подключение к Интернет (Internet Connection) стартует всякий раз,
    когда я пробую соединиться с InterBase.
6.  При попытке соединения я получаю следующее сообщение:
       Statement failed, SQLCODE = -902 (запрос потерпел неудачу)
       Unable to complete network request to host "DEV".
       (Невозможно завершить сетевой запрос для хоста "DEV".)
       -Failed to locate host machine. (невозможно найти хост-машину)
       -Undefined service gds_db/tcp. (сервис gds_db/tcp неопределен)
7.  Мое соединение с InterBase, похоже, очень медленно...
8.  Какие существуют Интернет-сервера, посвященные InterBase?
9.  Существуют ли 16-битные драйвера ODBC, позволяющие подключаться к
    InterBase NT, Netware или любому из серверов UNIX?
10. Почему Delphi 1.00 поставляется с 16-битными драйверами ODBC для
    InterBase?
11. Существуют ли 32-битные драйвера ODBC, позволяющие подключаться к
    InterBase NT, Netware или любому из серверов UNIX?
12. Поддерживают ли 32-битные драйвера ODBC DSN?
13. Почему Borland решил взимать плату за Local 32-битную версию?
14. Как мне подписаться на список рассылки InterBase Mailing List?
15. Если в этом FAQ'е нет ответа на мой вопрос, куда мне обратиться?
Вопросы и ответы по InterBase 4.2
16. Что такое InterBase 4.2?
17. Что нового в InterBase 4.2?
18. Для чего нужен Local InterBase?
19. Кто может быть пользователем InterBase Server под Windows 95?
20. Что включает в себя сервер InterBase под Windows 95?
21. Что включает в себя InterBase Server 4.2 for Windows NT?
22. Как осуществляется лицензирование InterBase?
23. Могу ли я свободно копировать ODBC драйвера InterBase?
24. Сколько стоит обновление до 4.2?
Вопросы/Ответы
  1. Что мне необходимо для распространения InterBase/Delphi приложения, созданного для нашего InterBase сервера?

    Вам необходимо следующее:

    1. BDE.
    2. SQL Links
    3. Клиентская лицензия

  2. Что мне необходимо для распространения InterBase/Delphi приложения, созданного дла работы с Local InterBase?

    Вам необходимо следующее:

    1. BDE
    2. SQL Links
    3. Local InterBase Server (смотри вопрос #3)

  3. Что юридически необходимо для распространения Local InterBase Server (LIBS)?

    Реально это зависит от версии, которую вы пытаетесь распространить. Delphi C/S 1.0 поставляется с неограниченной лицензией (Unlimited Distribution License), позволяющей распространять неограниченное число копий 16-битной версии LIBS. Тем не менее, для 32-битной версии лицензия Unlimited Distribution License недоступна. По 408-431-1000 вы сможете узнать текущие условия лицензирования.

  4. Я не могу подключить мои 32-битные приложения к моему серверу Novel...

    В настоящий момент соединение с помощью 32-битного SPX к InterBase невозможен, если вам необходимо подключить ваше 32-битное приложение к вашему серверу Novel, вы должны установить на нем поддержку протокола TCP/IP. (Это является следствием неготовности библиотеки 32 SPX Novel Libraries к моменту выхода SQL Links)

  5. Мое подключение к Интернет (Internet Connection) стартует всякий раз, когда я пробую соединиться с InterBase.

    Вам необходимо выключить флажок Auto Dial, который вы можете найти в Control Panel на страничке настройки Internet.

  6. При попытке соединения я получаю следующее сообщение:
    Statement failed, SQLCODE = -902 (запрос потерпел неудачу)
    Unable to complete network request to host "DEV".
    (Невозможно завершить сетевой запрос для хоста "DEV".)
    -Failed to locate host machine. (невозможно найти хост-машину)
    -Undefined service gds_db/tcp. (сервис gds_db/tcp неопределен)

    Следующая строчка должна присутствовать в services-файле как в вашем клиенте, так и на сервере:

    gds_db 3050/tcp Services-файлы могут располагаться в следующих каталогах:
    Windows95 -> C:\<WINDOWS95> (Где у вас установлен Win95)
    Windows NT -> C:\\System32\drivers\etc

  7. Мое соединение с InterBase, похоже, очень медленно...

    Это очень вероятно, если вы пользуетесь Netbeui, входящей в состав NT версии 4.0. Данная версия имеет ошибку, очень замедляющую работу Netbeui. Для решения проблемы попробуйте один из следующих рецептов:

    1. Обновите InterBase до самой последней версии.
    2. Установите, как вы обычно делаете, TCP/IP, это будет работать быстрее с любой версией InterBase.

    Примечание: Тестирование NT 4.0 и InterBase 4.2 с протоколами Netbeui и TCP/IP показало их равную производительность, а в некоторых случаях Netbeui был быстрее.

  8. Какие существуют Интернет-сервера, посвященные InterBase?

    На сегодняшний день я знаю 4 таких Интернет-сервера:

    InterBase Development
    http://www.xmission.com/~uldata/ib

    Mers Systems
    http://www.mers.com

    Dunstan Thomas InterBase Links
    http://www.demon.co.uk/dtuk/dtinterbaselinks.html

    Borland International
    http://www.borland.com/interbase

  9. Существуют ли 16-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX?

    Borland в настоящее время делает доступными 16-битные драйверы ODBC как часть продукта PC Client/Developer Toolkit [данное программное обеспечение также включается в пакеты InterBase для NT и сервера Netware]. Пользователи, приобредшие лицензии на PC Client/Developer Toolkit, имеют право устанавливать эти 16-битные драйвера. Цена за приобретаемый отдельно Client/Toolkit составляет $295, Borland использует для него товарный индекс ICL1140WWFN350.

  10. Почему Delphi 1.00 поставляется с 16-битными драйверами ODBC для InterBase?

    Delphi 1.00 содержал 16-битные драйвера ODBC для IB для того, чтобы все компоненты Delphi могли без проблем подключаться к серверу. Delphi 1.0 также включал SQL Link для InterBase, натив-драйвер с высокими скоростными характеристиками. Вопросы лицензирования не были явно или неявно отражены при пакетировании и в файлах deploy.txt драйвера ODBC, поэтому легальным пользователям продукта Delphi Client/Server не запрещается распространять продукты SQL Link и Local InterBase.

    В Delphi 1.02 драйверы InterBase ODBC были удалены, поскольку в необходимость в них компонентов Delphi отпала. Упоминание о драйверах остались в нескольких текстовых файлах, но это больше не требуется, так как в файлах deploy.txt содержится информация о правилах их распространения.

  11. Существуют ли 32-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX?

    Сегодня InterBase включает в себя 32-битные драйвера ODBC для Windows 95 и NT. Данные драйвера включены в InterBase 4.1 под NT и InterBase 4.2 под NT. Они были разработаны компанией Visigenic [смотри сообщение для прессы "Visigenic/Borland" на сервере www.borland.com]. Они также включены в Local InterBase под Win95/NT, который продается отдельно от Delphi. Драйвера также доступны как натив-драйвера для таких клонов UNIX, как Solaris, AIX и HP-UX. Никаких правил лицензирования не предусмотрено, а из существующих документов нельзя сделать выводы отностильно получения разработчикам доступа к драйверам путем покупки продуктов InterBase.

  12. Поддерживают ли 32-битные драйвера ODBC DSN?

    В настоящее время пока нет, в InterBase 4.2 возможность ODBC "DSN" была добавлена для поддержки соединений с серверными приложениями, такими, как сервера Web. Тем не менее, при использовании InterBase с серверами Web Server, для сервера необходимо иметь нужное число лицензий. Скоро Borland огласит свою политику отностительно лицензирования InterBase при работе с Интернет.

  13. Почему Borland решил взимать плату за Local 32-битную версию?

    (Смотри ниже подробное объяснение)

    Как вы, вероятно, уже знаете, Delphi C/S 1.0 включает в себя неограниченный в распространении Local InterBase [16-бит]. Мы [группа разработчиков InterBase] решили предложить эти беспрецендентные условия для распространения нашего продукта в среде разработчиков, демонстрации великолепия сервера и для увеличения полезности Delphi как средства разработки в среде Клиент/Сервер. Delphi Client/Server Suite 2.0 содержит Delphi Client/Server 1.0 и сохраняет условие свободного распространения Local InterBase [16-бит].

    Для 32-битных версий Delphi мы имеем:

    Delphi Desktop - не 32-битный InterBase любой сортировки [Desktop<>Client/Server]
    Delphi Developer - Local InterBase для Windows 95/NT включен, без распространения.
    Delphi C/S Suite 2.0 - Local IB для Win95/NT, IB Server NT на 2 пользователя, также без распространения.

    Почему без распространения?

    Во-первых, как вы можете увидеть из моих выкладок, новый продукт Local InterBase сертифицирован для использования в Windows 95 и Windows NT. Его архитектура полностью переписана с использованием нашего расширенного проекта SuperServer. Поскольку продукт разрабатывался как для Win95, так и для NT, Local InterBase настоятельно рекомендуется использовать в качестве отдельного сервера [MS не имеет сервера Win95; Oracle имеет один, но он имеет другой алгоритм программирования, чем NT server, они предлагают заплатить $400 за каждый 16- и 32-битный C API, и они посылают вас в InterSolv для ПОКУПКИ драйвера ODBC; Sybase имеет SQL Anywhere/Watcom и SQL Server 11 с другим API [ODBC против OpenClient], другой архитектурой и серьезными проблемами масштабируемости [продукт SQL Anywhere всегда использует Watcom с TransactSQL, но не использует OpenClient API, низкая многопользовательская производительность движка Watcom {для этого можно посмотреть последние обзоры в PC MAG за 10/94 и InfoWorld}, и так далее]; Informix не имеет ничего общего с работой на этих платформах; а Gupta свернула свою деятельность на этом поприще и кинулась разрабатывать High-End инструментарий для провайдеров, а не для серверов {если я правильно понял последнее сообщение для печати}]. 16-битные версии для отдельных пользователей отлично смотрелись в C/S пакете, в котором они распространялись. Ожидалось, что эти версии в пакете client/server должны быть свободными в распространении, но это не так.

    При продаже отдельно от Delphi и других клиентских продуктов Borland, продукт Local InterBase под Win95/NT будет сравниваться с SQL Anywhere, Personal Oracle и Personal Oracle Lite, и MS SQL Server Workstation.

    Мы включим наши C/C++ API для свободного использования.
    Мы включим наши 32-битные драйвера ODBC 2.5 под Win95/NT для свободного использования.
    Мы включим полную online-документацию, включая документацию по C API.
    Мы включим великолепную интеграцию в среду Win95/NT.
    Мы включим нативный 32-битный инструментарий.
    Мы предлагаем РАЗЛИЧНЫЕ наборы-пакеты для полного сервера [различающиеся только в поддерживаемых DDL, API, включаемой online-документацией и др.] с РАЗЛИЧНЫМ ценообразованием.

    Короче говоря, Local InterBase 32 предлагает бОльшие характеристики, лучшее взаимодействие с SQL [совместимость с уровнем ANSI 92, не '89], бОльшую универсальность [тот же комплект для Win95/NT], лучшую интеграцию с ОС, лучшую масштабируемость [мы работаем с 16 операционными системами, используя ОДНО И ТО ЖЕ API], лучшую производительность [поскольку вы пишите на одном API или посредством Delphi и никогда не переписываете свое приложение].

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

  14. Как мне подписаться на список рассылки InterBase Mailing List?

    Для подписки отправьте письмо по адресу listproc@esunix1.emporia.edu с командой "SUBSCRIBE INTERBASE Ваше Имя" в теле сообщения (без кавычек).

  15. Если в этом FAQ'е нет ответа на мой вопрос, куда мне обратиться?

    У вас имеется несколько доступных способов:

    1. Послать ваш вопрос в Compuserve GO BDEVTO (Секции 8 и 9)
    2. Послать ваш вопрос в список рассылки InterBase Mailing List (смотри Вопрос 14)
    3. Заключить контракт на поддержку (Support Contract) для InterBase и спросить службу технической поддержки (Technical Support)

    Вопросы и ответы по InterBase 4.2

  16. Что такое InterBase 4.2?

    InterBase 4.2 - новая версия сервера реляционной базы данных Borland InterBase под Windows 95 и NT.

  17. Что нового в InterBase 4.2?

    InterBase 4.2 - целое семейство новых продуктов, включающее в себя потокобезопасные клиентские библиотеки для Windows 95/NT, с расширенными 32-битными драйверами ODBC, расширенную версию Local InterBase, предназначенную для разработки отдельным пользователем и ее распространения, новый многопользовательский сервер под Windows 95 для небольших рабочих групп и новый сервер под Windows NT для разработки приложений уровня департамента и предприятия. InterBase 4.2 был создан с использованием расширенной версией архитектуры Borland SuperServer, что позволило поднять производительность продукта на небывалую высоту, сохранив при этом исторические преимущества InterBase и добавив легкость установки, удобство использования и разработки. Кроме того, InterBase 4.2 для Windows NT также содержит нового менеджера лицензий (License Manager), позволяющий системным администраторам легко и эффективно управлять пользователями баз данных.

  18. Для чего нужен Local InterBase?

    Local InterBase 4.2 разрабатывался для компаний и корпораций, поставляющих решения клиент/сервер для предприятий, которые имеют как автономных, так и сетевых пользователей. Local InterBase обеспечивает пользователей ноутбуков и рабочих групп автономным сервером баз данных, работающим на всех платформах Windows [Windows 3.1, 95 и NT], предлагая таким образом решение для сотрудников предприятий, имеющих нерегулярный доступ к сети. Поскольку Local InterBase использует тот же язык программирования и формат баз данных, что и семейство продуктов сервера InterBase [доступные для платформ Windows и UNIX], то приложения, созданные для использования с сервером InterBase, на 100% совместимы с Local InterBase, и не требуют внесений изменений для правильной работы.

  19. Кто может быть пользователем InterBase Server под Windows 95?

    Сервер InterBase под Windows 95 - многопользовательский сервер для рабочих и небольших групп. Совместимый с Windows 95, Windows NT Workstation и NT Server, InterBase Server под Windows 95 идеален для приложений, которые требуют не более 4 параллельных пользователей. Если потенциальное количество пользователей может быть 10 и более, InterBase Server под Windows 95 будет управлять соединениями для гарантии того, что будут активны не более 4 пользователей, это предохранит операционную систему Windows 95 от перегрузки с операциями, связанными с базами данных. InterBase Server под Windows 95 не требует для работы выделенной машины и может работать в сетевой среде типа "peer to peer", где сервер может обслуживать не только операции с базами данных.

  20. Что включает в себя сервер InterBase под Windows 95?

    Сервер InterBase под Windows 95 включает в себя клиентские библиотеки и драйвера ODBC, необходимые для распространения в пределах рабочей группы, которая планирует пользоваться сервером, а также сам сервер, устанавливаемый на одной из машин [обычно самая быстрая машина в группе]. Отдельные клиентские приложения, работающие с Local InterBase, легко адаптируются для работы с сервером InterBase под Windows 95, тем самым позволяя компаниям и крупным корпорациям легко масштабировать свои решения по мере увеличения к ним требований.

  21. Что включает в себя InterBase Server 4.2 for Windows NT?

    InterBase Server 4.2 под Windows NT включает в себя сервер InterBase, клиентские библиотеки InterBase [включая ODBC драйвера Win95/NT], менеджер лицензий License Manager, позволяющий системным администраторам легко и эффективно управлять пользователями баз данных, и высокопроизводительный 32-битный визуальный (GUI) инструментарий. Сервер InterBase под Windows NT фирмы Borland - наилучший выбор для сервера баз данных под Windows. Тестировавшийся и сертифицированный под NT 3.51 и 4.0, InterBase Server 4.2 легко справляется с задачами уровня крупного предприятия. Способный использовать многопроцессорные машины для максимальной производительности, InterBase Server 4.2 является наилучшим выбором для крупномасштабных приложений, требующих высокую скорость, легкость установки, удобство разработки и надежность эксплуатации.

  22. Как осуществляется лицензирование InterBase?

    InterBase предусматривает два типа лицензий: Named User (пользовательская) и Concurrent Server (серверная). Лицензия Named User рекомендуется для приложений, в которых количество пользователей, имеющих доступ к базе данных, является числом относительно постоянным, а вероятность добавления в сетевую среду серверов InterBase достаточно высока. Данная лицензия гарантирует, что любой пользователь NT Named Client будет иметь полный доступ ко всем серверам предприятия InterBase NT без необходимости приобретения лицензий для множества пользователей. Цена лицензии Concurrent Server позволяет разработчикам иметь определенное количество параллельно работающих пользователей, но при этом количество потенциальных пользователей может быть значительно большим. Если число потенциальных пользователей значительно превышает число паралельно работающих пользователей на текущий момент, лицензия Concurrent Server позволит вам в будущем сэкономить немало денег. Тем не менее, если к приложению прибавляются дополнительные сервера баз данных, вы должны иметь серверные лицензии в количестве паралелльно работающих пользователей, подключенных к этим серверам, даже если эти пользователи уже работают с другими серверами NT, имеющимися на предприятии. Таким образом, лицензия Named Client позволяет лицензировать и пользователей, и машины, и допускает подключение клиента к любому серверу предприятия NT, имеющему лицензию Named Client. Лицензия Concurrent Server лицензирует количество параллельно работающих на сервере пользователей и не предоставляет клиентам никаких клиентских лицензий.

  23. Могу ли я свободно копировать ODBC драйвера InterBase?

    Нет, но все пользователи InterBase 4.2, имеющие лицензию Named User, могут иметь копию клиентских библиотек InterBase и драйверов ODBC, установленных на их машине. Таким образом, если вы купили легальную лицензию для подключения к InterBase, вы имеете право на создание резервной копии. Аналогично этому, все пользователи InterBase 4.2 с лицензиями Concurrent Server также могут иметь копии клиентских библиотек и драйверов ODBC, установленных на их машине. Разработчики не могут копировать библиотеки 4.2 на машины незарегистрированных пользователей, или пользователей предыдущих версий InterBase [например, 4.0 и 4.1]. Пользователи этой группы должны обновить сервер до версии InterBase 4.2 или приобрести индивидуальные копии инструментария разработчика (Developer Toolkit) для каждого клиента, где имеются файлы этого инструментария [драйверы ODBC, GUI-утилиты и пр.].

  24. Сколько стоит обновление до 4.2?

    Клиенты InterBase 4.0 и 4.1 могут обновить InterBase до версии 4.2 за $499.95

[001065]


Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?

Nomadic советует:

Att.bat:
at 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT"
BR.bat:
del e:\IB_DATA\b.txt
del e:\IB_DATA\r.txt
del e:\ib_data\AR_IB.PRV
del e:\IB_DATA\AR_IB.GBK
d:\ib_42\bin\gfix -shut -force 1 e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo"
net stop "InterBase Server"
copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV
net start "InterBase Server"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK -user "SYSDBA" -password "oooo" -B -L -Y "e:\IB_DATA\b.txt"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo" -P 4096 -V -R -Y "e:\IB_DATA\r.txt"
Sergey Klochkovski
[001247]


Как скомпилиpовать UDF для Interbase под Linux RH 4.0?

Nomadic советует:

Пример -
#!/bin/sh
gcc -c -O -fpic udflib.c
ld -o libudf.so -shared udflib.o
cp libudf.so /usr/interbase/lib/
ldconfig -v >>/dev/null
[001249]


Как узнать текущие дату и время в Interbase?

Nomadic отвечает:
Дата + время - DATE.
Только дата - TODAY.
Только время - DATE-TODAY.
[001255]


После снесения через родной uninstall Interbase Server 5.0 для Windows и желания поставить 5.1.1 вылетает ошибка: IBCheck. Что делать?

Nomadic отвечает:

Решение найдено. Прочитай сам и передай товарищу:

Надо запустить regedit, и открыть ключ

HKEY_LOCAL_MACHINE\Environment
Там есть строка PATH. Так вот иногда она почему-то становится не строкой, а еще чем-то. Ее надо убить, и пересоздать как строку, прописав туда прежнее содержимое (в виде строки). [001257]


При попытке регистрации UDF возникает ошибка (udf not defined). Что не так?

Nomadic отвечает:

  1. Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);

  2. При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):
    declare external function f_SubStr
cstring(254), integer, integer
returns
cstring(254)
entry_point "Substr" module_name "UDF1"
    Где UDF1 - UDF1.DLL. [001326]


Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию?

Nomadic отвечает:

(Это очень полезно при прямой работе с IB из различного CASE-инструментария, типа PowerDesigner или ErWIN)

Чтобы не писать каждый раз COLLATE, я сделал следующее:

  1. Создал сохранённую процедуру
    create procedure fix_character_sets
as
begin
update
rdb$character_sets
set
rdb$default_collate_name = 'PXW_CYRL'
where
rdb$character_set_name = 'WIN1251'
and
rdb$default_collate_name = 'WIN1251'
;
end
  2. Запустил ее один раз.

  3. Создаю таблицы без указания COLLATE.

  4. После восстановления из архива, запускаю еще раз.
[001391]


Добавление ODBC-драйверов в Delphi 3

Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличие следующих компонентов:

        Microsoft ODBC Manger
        Windows 95 или NT
        Delphi версии Developer или Client/Server
        Поставляемый производителем драйвер ODBC (уже установленный в вашей системе)
При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.

Метод A:

  1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

  2. Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.)

  3. Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK.

  4. Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле "Path" (путь), или поле "Server" (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.)
Метод B:
  1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

  2. Щелкните на закладке database, затем правой кнопкой мыши на левой панели.

  3. Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK.

  4. Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply.

  5. Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply.
Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные.

Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив ‘virtual’ отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2). [001207]


Delphi 2

Связь Oracle с Win95

Оптимизация связи Oracle с Windows 95

Предварительные условия:

  • Windows 95
  • Установленное клиентское программное обеспечение для доступа к Oracle & программа для соединения с Oracle Server через TCP/IP.
  • (Опционально) Программное обеспечение Delphi 2.0 C/S для тестирования результатов.

Цель документа:

помочь увеличить скорость соединения Oracle под Windows 95. Под WinNT такая проблема не стоит, следовательно, данный документ рассматривает только работу с Windows 95. Ниже вы видите разницу в скорости выполнения запроса, выполненного до модификации, и после:

До     : Win95 = 10-15 секунд.
     WinNT = 2-3   секунд.

После  : Win95 = 3-4   секунд. (Большое улучшение)
Проблема: Windows 95 в сущности ищет адреса IPC в нескольких сетевых узлах ДО получения соединения с Oracle DNS, WinNT же поступает по другому.

Решение: Измените файл Oracle SQLNET.ORA для выключения вышеуказанной характеристики Windows 95.

Решение шаг-за-шагом:

  1. Откройте в Notepad или Write файл SQLNET.ORA. (Данный файл расположен в каталоге <ORA_HOME>\network\admin. Проигнорируйте любые другие разновидности этого файла)

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

    ################
# Filename......: sqlnet.ora
# Node..........: local.world
# Date..........: 24-MAY-94 13:23:20
################
TRACE_LEVEL_CLIENT = OFF
sqlnet.expire_time = 15
names.default_domain = borland.world
name.default_zone = borland.world
  2. Добавьте следующий параметр в файл SQLNET.ORA:
        AUTOMATIC_IPC = OFF
    После изменений файл должен выглядеть примерно так:
    ################
# Filename......: sqlnet.ora
# Node..........: local.world
# Date..........: 24-MAY-94 13:23:20
################
AUTOMATIC_IPC = OFF
TRACE_LEVEL_CLIENT = OFF
sqlnet.expire_time = 15
names.default_domain = borland.world
name.default_zone = borland.world
  3. Сохраните измененный файл SQLNET.ORA и ура! В дальнейшем при инициализации соединения с Oracle время соединения вместо 15 секунд составит всего лишь 3 секунды. Скорость работы Delphi существенно увеличится.
[001075]


Возникла необходимость в обработке исключительных ситуаций в PL/SQL процедуре (Oracle7 WG Server Release 7.3.2.2.0). Почему у меня не получается?

Nomadic отвечает:

Объявить выборку SELECT * FROM CUSTOM.CAMAIN20TEMP WHERE CC_07_01=curCC_07_01 AND CC_07_02=curCC_07_02 AND CC_07_03=curCC_07_03 курсором, а потом примерно так:

loop
fetch_cursor;
выход когда фетчить больше нечего;
begin
INSERT INTO CUSTOM.CAMAIN20 чего нафетчили;
EXCEPTION
WHEN others THEN
BEGIN
DBMS_OUTPUT.PUT_LINE('ВВОД ДУБЛЯ В CUSTOM.CAMAIN20');
END
end
end loop;
[001238]


Поясните, чем в Oracle являются понятия Instance, Database etc.?

Nomadic отвечает:

Перевод документации:

Что такое ORACLE Database?

Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.

Что такое ORACLE Instance?

ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открыть только одну database. В то время как одна database может быть открыта несколькими Instance.

Instance состоит из:

SGA (System Global Area), которая обеспечивает коммуникацию между процессами;
до пяти (в последних версиях больше) бэкграундовых процессов.

От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents. [001274]


Как заставить Oracle анализировать все таблицы базы данных?

Nomadic отвечает:

Конечно, можно использовать DBMS_SQL, DBMS_JOB...

А можно и так:

#!/bin/sh
#
# Analyze all tables
#

SQLFILE=/tmp/analyze.sql
LOGFILE=/tmp/analyze.log

echo @connect dbo/passwd@ > $SQLFILE

$ORACLE_HOME/bin/svrmgrl <> $SQLFILE
connect dbo/passwd
SELECT 'TABLE', TABLE_NAME FROM all_tables WHERE owner = 'DBO';
EOF

echo exit >> $SQLFILE
cat $SQLFILE > $LOGFILE

cat $SQLFILE | $ORACLE_HOME/bin/svrmgrl >> $LOGFILE

cat $LOGFILE | /usr/bin/mailx -s 'Analyze tables' tlk@nbd.kis.ru

rm $SQLFILE
rm $LOGFILE
[001280]


В режиме отладки приложения не разрешается доступ (открытие) базы данных. Как лечить?

Nomadic отвечает:

Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте - совет от ORACLE.
Глюк имеет место быть только под Windows NT 4.xx. [001282]


Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?

Nomadic отвечает:

Ставить в initmybase.ora

compatible = "7.3.2.3"
и после старта с новым параметром сделать
ALTER DATABASE RESET COMPABILITY;
И рестартовать базу. [001349]


Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE?

Nomadic отвечает:

прописать в \HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:

NLS_NUMERIC_CHARACTERS = '.,'
или

после соединения с ORACLE выполнить

ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'
[001363]


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

Как в Oracle создать sequence с некоторого номера?

Nomadic отвечает:

create sequence minvalue 10;
[001371]


Как решать некоторые вопросы при подключении к Oracle?

Nomadic отвечает:

DD> 1. Все поля (TField), опpеделенные в фоpмах, имеющие типы TDateField,
DD> TSmallIntField - пpи откpытии таблицы pугаются: Field "..." is not of
DD> expected type. Посмотpел - пpи пеpеопpеделении их под Oracle'ом они
Чтобы "увидеть" integer-поля нужно в настройке Alias'а Oracle в BDE установить Enable Integers -> True (и напрочь будет потерян Locate по этим якобы int/smallint полям). С датами, возможно, тоже надо разбираться через настройки Win & Oracle. У меня в Win дата формата "дд.мм.гггг", в Oracle NLS_LANG -> AMERICAN_AMERICA.CL8MSWIN1251 и с датами все гут.

DD> 2. Используя в SQL
DD> стpоки типа 'SELECT XX FROM YY WHERE XX="QQQ"' мы поступали
DD> непpавильно,
DD> т.к. двойные кавычки в Oracle обpабатывабтся не так, как в Btrieve.
Oracle в данном случае не причем. Это глюк BDE. Лечилось просто - вместо обрамления двойными кавычками строкового значения, нужно обрамлять его с помощью #39, примерно так

MySQLString := 'SELECT XX FROM YY WHERE XX='+#39+'QQQ'+#39;

Belsky Roman
(2:450/94.75)

SS> У кого-нибудь есть опыт по настройке BDE ? Откликнитесь плиз! При
SS> попытке соединиться с базой вылезает ошибка: Vendor failed init!
SS> Delphi запускаю под 95. Hа всякий случай пути к \BDE и ORAWIN\BIN я
SS> проставил! orant71.dll (родной или переименнованый ora72win.dll)
SS> закидывал куда угодно, но.... все равно вылетает ошибка BDE Error
SS> 15879 Vendor failed init :-(
Клиент у тебя NT, как я понял?
  • ora7x.dll - 32bit клиент для win95
  • orant7x.dll - 32bit клиент для NT
  • ora7xwin.dll - 16bit клиент для win
т.е. ora7xwin в Delphi3 вообще ставить бесполезно (16bit для 32bit appl). ora*71.dll у меня изначально к ORACLE 7.2 не коннектился - они там как-то резко сменили OCI. Правда потом ora72win.dll с Personal Oracle 7.3 работал, но все равно лучше, наверное, чтобы номер версии dll был не ниже версии сервера.

А вообще я 32bit дельфях в Vendor Init давно прописываю OCIW32.dll - он всегда для последней версии сервера с которым ты работаешь.

Это IMHO. Hо у меня Delphi3 и Delphi1 коннектятся как с Oracle 7.1 на Unix'е, так и с Personal Oracle 7.3 [001373]


WindowsNT 4.0 + Delphi 2.01 C/S + Oracle Client 7.3 + Oracle Server 7.3. После логина в базу данных возникает `EExternalError 0xC0000008`. Что делать?

Nomadic коротко отвечает:

A: (IA, SK): Снести Oracle Trace Collection Services. [001504]


Как правильно соединяться с базой данных под Personal Oracle?

Nomadic коротко отвечает:

A: user/password@2: Это так для Oracle SQL Plus, и более других его утилит. А в BDE надо оставить все как для соединения с сетевым сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную DLL) только вместо имени сервера написать "2:". Это годится и для случая, когда на одной машине и сетевой сервер и приложение. [001571]


Delphi 1

Получение пути псевдонима и таблицы I

Есть три способа сделать это... No1 годится только для постоянных псевдонимов BDE. No2 работает с BDE и локальными псевдонимами, и No3 работает с BDE и локальными псевдонимами, используя "тяжелый" путь, через вызовы DBI.

function GetDBPath1(AliasName: string): TFileName;
var ParamList: TStringList;
begin
ParamList := TStringList.Create;
with Session do
try
GetAliasParams(AliasName,ParamList);
Result := UpperCase(ParamList.Values['PATH'])+'\';
finally
Paramlist.Free;
end;
end;

function GetDBPath2(AliasName: string): TFileName;
var ParamList: TStringList;
i: integer;
begin
ParamList := TStringList.Create;
with Session do
try try
GetAliasParams(AliasName,ParamList);
except
for i:=0 to pred(DatabaseCount) do
if (Databases[i].DatabaseName = AliasName) then
ParamList.Assign(Databases[i].Params);
end;
Result := UpperCase(ParamList.Values['PATH'])+'\';
finally
Paramlist.Free;
end;
end;

function GetDBPath3(ATable: TTable): TFileName;
var TblProps: CURProps;
pTblName, pFullName: DBITblName;
begin
with ATable do
begin
AnsiToNative(Locale, TableName, pTblName, 255);
Check(DBIGetCursorProps(Handle, TblProps));
Check(DBIFormFullName(DBHandle,
pTblName,
TblProps.szTableType,
pFullName));
Result := ExtractFilePath(StrPas(pFullName));
end;
end;

- Reinhard Kalinke [001020]


Получение пути псевдонима и таблицы II

Вот маленький примерчик того, как в Delphi можно получить информацию о псевдонимах. Для начала создайте новый проект с ListBox и тремя метками (с именамиListBox1, Label1, Label2 и Label3). Затем создайте обработчик события формы OnCreate с примерно следующим кодом:

procedure TForm1.FormCreate(Sender: TObject);
begin
Session.GetAliasNames(ListBox1.Items);
end;

Теперь создайте обработчик OnClick для ListBox:

procedure TForm1.ListBox1Click(Sender: TObject);
var
tStr: array[0..100] of char;
Desc: DBDesc;
begin
if ListBox1.Items.Count = 0 then
exit;
StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr));
DbiGetDatabaseDesc(tStr, @Desc);
with Desc do
begin
Label1.Caption := StrPas(Desc.szName);
Label2.Caption := StrPas(Desc.szPhyName);
Label3.Caption := StrPas(Desc.szDbType);
end;
end;

Добавьте следующие модули в секцию 'uses' в верхней части модуля:

DB, DBTables, DBITypes, DBIProcs;

Теперь вы можете увидеть путь для всех ваших стандартных псевдонимов (Paradox и dBase). [001287]


Delphi 1

Получение пути псевдонима и таблицы III

Используйте Session.GetAliasParams. В ответ вы получите объект Tstrings, откуда вы можете получить значение для переменной 'PATH". Для получения дополнительной информации обратитесь к электронной справке к разделу, описывающему TSession. Объект Session объявлен в модуле DB.

uses
db;

var
aliaspath : string[128];

begin
aliaspath := Session.GetAliasParams['MyAlias'].values['PATH'];
end;

uses SysUtils,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;

[001316]


Получение пути псевдонима и таблицы IV

Nomadic советует:

  1. По таблице (фактически по Database) получить физическое местонахождение.

Примечание: Database можно создать явно, если нет, Дельфи сама его создаст, доступ к ней по Table(Query).Database

uses

DbiProcs;

function GetDirByDatabase( Database: TDatabase ): string;

var

pszDir: PChar;

begin

pszDir := StrAlloc( 255 );

try

DbiGetDirectory( Database.Handle, True, pszDir );

Result := StrPas( pszDir );

finally

StrDispose( pszDir );

end;

end;

  2. По алиасу.

function GetPhNameByAlias( sAlias: string ): string;

var

Database: TDatabase;

pszDir: PChar;

begin

Database := TDatabase.Create( nil ); {allocate memory}

pszDir := StrAlloc( 255 );

try

Database.AliasName := sAlias;

Database.DatabaseName := 'TEMP'; {requires a name -- is ignored}

Database.Connected := True; {connect without opening any table}

DbiGetDirectory( Database.Handle, True, pszDir ); {get the dir.}

Database.Connected := False; {disconnect}

Result := StrPas( pszDir ); {convert to a string}

finally

Database.Free; {free memory}

StrDispose( pszDir );

end;

end;

[001357]


Delphi 1

Информация о псевдониме BDE

var MyAliasPath: string;
const AliasName='MyAlias';

{**** Получаем из BDE путь MyAlias}

ParamsList:= TStringList.Create;

try
with Session do
begin
Session.GetAliasNames(ParamsList);
Session.GetAliasParams(AliasName,ParamsList);
MyAliasPath:=Copy(ParamsList[0],6,50)+'\';
end;
finally
ParamsList.Free;
end;

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;

[001217]


Delphi 1

Изменение каталога псевдонима во время выполнения приложения

Я делаю это все время. У меня есть INI-файл, который сообщает, где можно найти таблицы и каталоги их расположения. Вот как я это делаю:

procedure CheckTable( var Table : TTable; var TName : string );
var
ChangePath  : boolean;
Path        : string;
ActiveState : Boolean;
begin
if ( TName = '' ) then
TName := Table.TableName
else
with Table do
begin
ActiveState := Active;
Close;
Path := ExtractFilePath( TName );
ChangePath := HasAttr( DatabaseName, faDirectory  ) or
( CompareText( DatabaseName, Path ) <> 0  );
if ( Length ( Path ) > 0 ) and ChangePath then
DatabaseName := Path;
if ( CompareText( ExtractFileName( Tname ), TableName ) <> 0 )
then
TableName := ExtractFileName( Tname );
Active := ActiveState;
end;
end;

[001225]


Delphi 2

Псевдоним на лету

Попробуйте это:

type
TDataMod = class(TDataModule)
Database: TDatabase;
public
procedure TempAlias(NewAlias, NewDir: String);
end;

procedure TDataMod.TempAlias(NewAlias, NewDir: String);
begin
with Session do
if not IsAlias(NewAlias) then
begin
ConfigMode := cmSession;  (* NewAlias будет ВРЕМЕННЫМ *)
try
AddStandardAlias(NewAlias, NewDir, 'PARADOX');
Database.Close;
Database.AliasName := NewAlias;
Database.Open;
finally
ConfigMode := cmAll;
end;
end;
end;

Комментарии:

a) Поместите компонент Database на форму DataModule;
b) Задайте свойству DatabaseName имя базы данных, например, 'TempDB';
c) Задайте свойству DatabaseName компонента TTable значение = 'TempDB'
d) Для получения дополнительной информации ознакомьтесь с примером MastApp, поставляемым вместе с D2. [001209]


Delphi 2

Псевдонимы

Попробуйте следующий код:

var
theStrList : TStringList;
GPath      : String;
begin
theStrList := TStringList.Create;

{Используем GetAliasParams для получения псевдонимов и ассоциированных с ними путей}
Session.GetAliasParams(<Здесь псевдоним из выпадающего списка>,theStrList);

{Удаляем первые шесть символов, которые всегда равны "PATH="}
GPath := copy(theStrList[0],6,length(theStrList[0]))

theStrList.Free;

[001211]


Delphi 2

Ошибка BDE32 $2104

Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:

EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'

При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).

- Pat Ritchey [001097]


Проблема BDE при использовании "неживого" TQuery

У меня была та же проблема, и я нашел единственное решение как ее обойти. Я подозреваю, что причина кроется в том, что Query1.Refresh ничего не делает, если установлен режим readonly, т.е. не ожидается никаких изменений. Один способ у меня прошел успешно (в предположении, что мы имеем один вход): я использовал 3 TQuerie, две сетки и форму обновления. Это способ, когда я могу установить requestlive в истину. Вы не должны допускать, чтобы пользователь мог сам редактировать табличную сетку (если это то, что вы хотите). [001219]


Делаем ApplyUpdates. Если пpи insert(update) пpоизошла ошибка (поле null, сpаботал check, etc.), то BDE всегда говоpит "General SQL Error" вместо ноpмального сообщения об ошибке :-( Без CU все ноpмально, pазумеется. Как боpоть этот баг?

Nomadic советует:

Использyй ноpмальнyю тpансляцию ошибок в Application.OnException. Вpоде это.

procedure DBExceptionTranslate(E: EDBEngineError);

function OriginalMessage: String;

var

I: Integer;

DBErr: TDBError;

S: String;

begin

Result := '';

for I := 0 to E.ErrorCount - 1 do

begin

DBErr := E.Errors[I];

case DBErr.NativeError of

-836: { Intebase exception }

begin

S := DBErr.Message;

Result := #13#10 + Copy(S, Pos(#10, S) + 1, Length(S));

Exit;

end;

end;

S := Trim(DBErr.Message);

if S <> '' then Result := Result + #13#10 + S;

end;

end;

begin

case E.Errors[0].ErrorCode of

$2204:

E.Message := LoadStr(SKeyDeleted);

$271E,$2734:

E.Message := LoadStr(SInvalidUserName);

$2815:

E.Message := LoadStr(SDeadlock);

$2601:

E.Message := LoadStr(SKeyViol);

$2604:

E.Message := LoadStr(SFKViolation) + OriginalMessage;

else

begin

E.Message := Format(LoadStr(SErrorCodeFmt), [E.Errors[0].ErrorCode]) +

OriginalMessage;

end;

end;

end;

[001253]


Delphi 1

Ошибка создания дескриптора курсора

Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:

Begin
.....
UpdateStudent.ExecSql;
.....
End;

Ваш запрос является Passtrough-запросом, который не может возвратить установленный результат, так что это не может быть открыто, а должно быть 'ВЫПОЛНЕНО'. [001271]


При разрушении обьектов, порожденных от TDataSet (TTable, TQuery), не отрабатывает событие OnBeforeClose. Что делать?

Nomadic отвечает:

Недоработка в VCL.
Сейчас вышел из ситуации так: в TForm.OnClose, т.е. пока ещё все компоненты формы живы, делаю CloseDatabases(Self). [001284]


При обращении к memo-полю из BDE возникает ошибка 'Memo too large'. Как лечить?

Nomadic отвечает:

В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально.

Эффект имеет место только с IB, вроде. [001290]


Delphi 1

Нарушение уникальности записи

try
tMyTable.Post;
except
on E : EDBEngineError
do
if E.Message = 'Key violation'
then
begin
MessageDlgC ('Дублирование записи не допускается.'
mtError, [mbOk], 0);
// Я не уверен в том, что это нужно делать:
tMyTable.Cancel;
end
else Raise;
end;

Хорошим примером может служить проект DBERRORS.DPR, расположенный в каталоге Delphi 2 Demos. Выглядит это примерно так:

Создайте функцию типа этой:

function DBError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
const
eKeyViol = 9729;
var
iDBIError: Integer;
begin
if (E is EDBEngineError) then
begin
iDBIError := (E as EDBEngineError).Errors[0].Errorcode;
case iDBIError of

eKeyViol:
begin
MessageDlg('Нарушение уникальности записи ', mtWarning,
[mbOK], 0);
Abort;
end;
end;

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

procedure TMainForm.Table1EditError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
begin
DBError(Table1, E, Action);
end;

Таким образом вы можете перехватить множество ошибок. Смотрите примеры от Borland, там много чего есть полезного. [001291]


При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'. Как лечить?

Nomadic отвечает:

Запросы вида

SELECT c, b, a, q FROM T WHERE b = :b,
где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку.

Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *. [001328]


Как поймать свой RAISEERROR в Delphi?

Nomadic отвечает:

procedure TFDMUtils.GeneralError( DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
var
i: Word;
ExtInfo : String;
begin
ExtInfo := '';

if (E is EDBEngineError) then
begin
if ( EDBEngineError( E ).Errors[0].NativeError = 0 ) then
begin // Local Error
if EDBEngineError( E ).Errors[0].Errorcode = 9732 then
ExtInfo := DataSet.FieldByName( trim( copy( E.Message, 29, 20 ) ) ).DisplayLabel;
.......................................
 end
else
begin // Remote SQL Server error
ExtInfo := ExtractFieldLabels( DataSet, E.Message );
case EDBEngineError( E ).Errors[0].NativeError of
233, 515 :
Alert( 'Ошибка', 'Hе все поля заполнены ! ' + ExtInfo );
547 :
if ( StrPos( PChar( E.Message ), PChar('DELETE' ) ) <> nil ) then
Alert('Ошибка пpи удалении', 'Имеются подчиненные записи, удаление (изменение) невозможно! ' + ExtInfo )
else
if ( StrPos( PChar( E.Message ), PChar( 'INSERT' ) ) <> nil ) then
Alert( 'Ошибка пpи вставке', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo )
else
if ( StrPos( PChar( E.Message ), PChar( 'UPDATE' )) <> nil ) then
 Alert( 'Ошибка пpи обновлении', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo );
2601 :
Alert( 'Ошибка', 'Такая запись уже есть!' );
else
 Alert( 'Ошибка', 'Hеизвестная ошибка, код - ' + inttostr( EDBEngineError( E ).Errors[0].NativeError ) + ExtInfo);
end;
end;
end;
end;

Этот код был заточен под MSSQL, но не нужно пытаться его использовать, а лучше по этому пpимеpу написать свою процедуру. [001336]


Как добиться верной работы фильтра на запросах и на неиндексированных таблицах?

Nomadic отвечает:

(Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи)

Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable.
Лечится так (простой пример):

procedure TMainForm.Edit1Change(Sender: TObject);
begin
if length( Edit1.Text ) > 0 then
begin
Table1.Filtered := TRUE;
UpdateFilter( Table1 );
end
else
Table1.Filtered := FALSE;
end;

procedure TMainForm.UpdateFilter( DataSet: TDataSet );
var
FR: TFilterRecordEvent;
begin
with DataSet do
begin
FR := OnFilterRecord;
if Assigned(FR) and Active then
begin
DisableControls;
try
OnFilterRecord := nil;
OnFilterRecord := FR;
finally
EnableControls;
end;
end;
end;
end;

[001353]


Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?

Nomadic отвечает:

sqlstate='99999' не подходит, так как хочется на клиенте видеть код исключения.

Используй RAISERROR с кодом >20000. Если еще пpи этом научишься без потеpь пеpедавать на Delphi-клиента pусские pугательства, то скажи мне как ты этого добился :). [001395]


Когда я применяю ApplyUpdates на ClientDataSet, на серверной стороне не срабатывает событие OnNewRecord для оригинального набора данных. Как это исправить?

Nomadic отвечает:

Никак. Эти обновления идут прямо через BDE, а не через компонент набора данных.

В Delphi 4.0 (C++Builder 4.0) ситуация радикально изменилась.

Во-первых, обычному провайдеру данных (TProvider) можно указать, каким образом обновлять данные.

Во-вторых, новый тип провайдера (TDataSetProvider) работает только через соответвующие методы TDataSet.

То есть - все события при данных условиях на сервере будут отрабатываться обычным образом.

Если же Вы пользуетесь более старой версией Delphi, то, как обычно, можно посоветовать использование хранимых процедур, в данном контексте это будут методы сервера приложений. К сожалению, совет неприемлем для транспорта Sockets. [001429]


Функции дат в SQL

Тема: Функции дат в SQL

Кто-нибудь знает как "вытащить" месяц или год из datetime-поля с помощью SQL? Я знаю, что QBE этого не может. SQL в состоянии это сделать?

Как насчет функции EXTRACT?

  SELECT SALEDATE,
    EXTRACT(DAY FROM SALEDATE) AS DD,
    EXTRACT(MONTH FROM SALEDATE) AS MM,
    EXTRACT(YEAR FROM SALEDATE) AS YY
  FROM ORDERS
- Steve Koterski [001009]


Зарезервированные слова Local SQL

Ниже приведен список в алфавитном порядке слов, зарезервированных Local SQL в Borland Database Engine. Имейте в виду, что данный совет публикуется "как есть".

ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING, AT, AUTO, AUTOINC, AVG

BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY, BYTES

CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT, CURSOR

DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT, DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP

ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS, EXIT, EXTERNAL, EXTRACT

FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION

GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP, GROUP_COMMIT_WAIT_TIME

HAVING, HOUR

IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT, INTEGER, INTO, IS, ISOLATION

JOIN

KEY

LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE, LOG_BUFFER_SIZE

MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME, MONEY, MONTH

NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS, NUMERIC

OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW

PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION, POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES

RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION, REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE, RIGHT, ROLLBACK

SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE, STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING, SUM, SUSPEND

TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE, TO, TRAILING, TRANSACTION, TRIGGER, TRIM

UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER

VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW

WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE

YEAR

Операторы:

||, -, *, /, <>, <, >, ,(запятая), =, <=, >=, ~=, !=, ^=, (, )

[001022]


Сиротские Master-записи

Как с помощью SQL найти записи таблицы, которых нет в другой таблице?

Вот пример:

with PeopleHiddenForm.PersonQuery.SQL do begin
Add('Select P.Last, P.First, P.Middle, P."Suffix", P.KeyNo, COUNT(PersMemL.PersonKeyNo)');
Add('From   Person P Left Outer Join ');
Add('       PersMemL PersMemL');
Add('On     ((P.KeyNo = PersMemL.PersonKeyNo))');
Add('Group By P.Last, P.First, P.Middle, P.Suffix, P.KeyNo');
Add('Having ((Count(PersmemL.PersonKeyNo) = 0))');

Данный код позволяет связаться с таблицей (PersMemL), содержащей количество ключей персональной записи и запись членства. Запрос возвращает имена персон, которые не имеют записей членства.

На практике этот способ оказывается очень эффективным, по крайней мере, с локальным SQL в таблицах Paradox.

- David G. Wachtel [001048]


Delphi 1

Назначение SQL-счетчика переменной

query.Close;
query.SQL.Clear;
query.SQL.Add('select count(*) from table where field = :XXX');
Query.ParamByName('XXX').AsString := value;
query.Open;
while Query.Eof <> True do
begin
SqlCount := Query.Fields[0].AsInteger;
Query.Next
end;

Подразумевается наличие компонентов TTable, TQuery, TStoredProc

Объявление

property RecordCount: Longint;

Описание

Времени исполнения и только для чтения. Свойство RecordCount определяет количество записей в наборе данных. Количество возвращаемых записей может зависеть от сервера и не зависит от границ задаваемого диапазона. [001216]


Как удобнее работать с динамически формируемыми запросами?

Nomadic советует:

В процессе работы с БД иногда необходимо выполнить какие-то мелкие запросы. Держать для этого где-то временную Query меня лично ломает, посему ловите творение (под Delphi) - модуль для создания временных TQuery и работы с ними.

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

var S:string;
...
S := FastLookUp( format( 'select A.F1 from A,B where A.F4=B.F4 and B.F9=%d', [1] ) );
with GiveMeResultSet( 'select*from A where F1="777"' ) do
try
....
 finally
Free; {не забудьте!}
end;
.....
if NOT ExecuteSQL( 'delete from A' ) then ShowMessage( 'Something Wrong' );
.....

Сам модуль идёт ниже -

{
Temporary Queries Creatin' and handlin'

(c) 1997-98 by Volok Alexander (D1/D2)

creation date: 30.10.1997
last update : 17.06.1998
}
 unit TmpQuery;

interface

uses
DBTables;

const
InternalDBname = 'MAIN'; {Изменять по вкусу - TDataBase.DataBaseName}

type
TSQLScript = {$IFDEF WIN32} string {$ELSE} PChar {$ENDIF};

{Создаст куери с текстом запроса, но не откроет его}
 function CreateTempQuery(SQLscript: TSQLscript): TQuery;

{Создаст куери и откроет запрос - не забудьте прибить}
function GiveMeResultSET(SQLscript: TSQLscript): TQuery;

{Проверит непустоту выборки, заданной ...}
function CheckExistence(SQLscript: TSQLscript): boolean;

{Вытащит аж одно значение(лукап) из выборки, заданной ...}
function FastLookUP(SQLscript: TSQLscript): string;

{Выполнит запрос и сообщит результат}
function ExecuteSQL(SQLscript: TSQLscript): boolean;

implementation

uses
Forms;

function CreateTempQuery(SQLscript: TSQLscript): TQuery;
begin
Result:= TQuery.Create(Application);
with Result do
begin
DatabaseName := InternalDBname;
{$IFDEF WIN32}
SQL.Text := SQLscript;
{$ELSE}
SQL.SetText(SQLscript);
{$ENDIF}
end;
end;

function ExecuteSQL(SQLscript: TSQLscript): boolean;
begin
with CreateTempQuery(SQLscript) do
begin
try
 ExecSQL;
Result := True;
except
Result := False;
end;
Free;
end;
end;

function CheckExistence(SQLscript: TSQLscript): boolean;
begin
with GiveMeResultSET(SQLscript) do
begin
Result := NOT EOF;
Free;
end;
end;

function GiveMeResultSET(SQLscript: TSQLscript): TQuery;
begin
Result := CreateTempQuery(SQLscript);
with Result do
try
Open;
except
Free;
Result:= NIL;
end;
end;

function FastLookUP(SQLscript: TSQLscript): string;
begin
with GiveMeResultSET(SQLscript) do
begin
try
Result:= Fields[0].AsString;
except
Result:= '';
end;
Free;
end;
end;

end.

[001244]


Delphi 1

Поиск записи в SQL DataSet

В случае изменения содержимого полей редактирования сделайте следующее:

Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('SELECT * FROM <таблица> WHERE <поле> Like ''' +
SpeedEdit.Text + '*''');

Query1.Open;

Будут возвращены все записи, указанные в поле редактирования. [001275]


При попытке выполнения такого оператора SQL - 'DELETE from T39 T39C0 WHERE T39C0.F1LHT35=253291661' SQL-сервер ругается на недопустимый синтаксис. В чем я неправ?

Nomadic отвечает:

В данном случае, видимо, T39C0 расценивается как псевдоним. Hо стандартом SQL-92 такое запрещено в DELETE.

Цитата собственно из этого стандарта (сборник из delete и names and identifiers, определение identifier пропущено, просто набор <simple latin letter> | <digit>, начинается с буквы):

Format
<delete statement: positioned>::=
delete from <table name> where current of <cursor name>

<table name> ::= <qualified name> | <qualified local name>
<qualified name> ::= [<shema name><period>] [<qualified identifier>]
<qualified identifier> ::=<identifier>
<shema name>::=[<catalog name><period>]<unqualified shema name>
<unqualified shema name>::=<identifier>
<catalog name>::=<identifier>
<qualified local name>::= MODULE <period><local table name>
<local table name>::=<qualified identifier>
Стандартом запрещено вот такое
select test.a, p_test.a from test p_test;
вот это не по стандарту, хотя Microsoft SQL Server такое ест. [001286]


Delphi 1

Поиск с помощью SQL

Предположим:

  1. если вашей таблицы определены следующие поля...
    last_name char (n),
first_name char (n)
    то...
    select
  last_name+', '+first_name
from
  person
where
  first_name='john'
  2. если вашей таблицы определены следующие поля...
    person_name char (n)  (например, Lennon, John)
    то...
    select
  person_name
from
  person
where
  person_name like '%John'  <--- 'John' должен быть в конце строки, еще используйте '%John%'
[001346]


Как получить результирующим полем разницу между хранимой датой и текущей датой?

Nomadic отвечает:

SELECT CAST((поле_с_датой -"NOW") AS INTEGER) FROM MyBase
Получишь результат в днях. [001351]


Delphi 1

SQL и поле даты

Есть множество способов сделать это:

  1. Если дата константа, используйте:
            WHERE Date = #31/11/95#
    В зависимости от "настроек вашей страны", это могло бы быть и #11/31/95#. Попробуйте оба: один из них работает.

  2. Если дата является переменной, вы должны воспользоваться параметром, например так:
            WHERE Date = :MyDate
    Затем, после нажатия на ok, выберите в Инспекторе Объектов для Query свойство Params, нажмите на кнопку с тремя точками, и установите MyDate как тип Date.
    SELECT * from PFMANUAL WHERE PRMANUAL."DATE" = "31/11/95"
    Я обнаружил это после решения аналогичной проблемы, когда для создания QBE-запроса я использовал DataBase Desktop, а затем "переводил" запрос на SQL.
[001354]


SQL-запросы в Delphi

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

Введение
Компонент TQuery
Свойство SQL
Свойство Params
Источник данных
Команда Format
Open против ExecSQL
Компонент TStoredProc
TDatabase
Выводы

1. Введение

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

Данный документ делает акцент на втором методе доступа к базам данных, на основе запросов SQL (pass-through). Авторы не стремились создать курсы по изучению синтаксиса языка SQL и его применения, они ставили перед собой цель дать несколько примеров использования компонентов TQuery и TStoredProc. Но чтобы сделать это, необходимо понимать концепцию SQL и знать как работают selects, inserts, updates, views, joins и хранимые процедуры (stored procedures). Документ также вскользь касается вопросов управления транзакциями и соединения с базой данных, но не акцентирует на этом внимание. Итак, приступая к теме, создайте простой запрос типа SELECT и отобразите результаты.

2. Компонент TQuery

Если в ваших приложениях вы собираетесь использовать SQL, то вам непременно придется познакомиться с компонентом TQuery. Компоненты TQuery и TTable наследуются от TDataset. TDataset обеспечивает необходимую функциональность для получения доступа к базам данных. Как таковые, компоненты TQuery и TTable имеют много общих признаков. Для подготовки данных для показа в визуальных компонентах используется все тот же TDatasource. Также, для определения к какому серверу и базе данных необходимо получить доступ, необходимо задать имя псевдонима. Это должно выполняться установкой свойства aliasName объекта TQuery.

Свойство SQL

Все же TQuery имеет некоторую уникальную функциональность. Например, у TQuery имеется свойство с именем SQL. Свойство SQL используется для хранения SQL-запроса. Ниже приведены основные шаги для составления запроса, где все служащие имеют зарплату свыше $50,000.

  1. Создайте объект TQuery

  2. Задайте псевдоним свойству DatabaseName. (Данный пример использует псевдоним IBLOCAL, связанный с демонстрационной базой данных employee.gdb).

  3. Выберите свойство SQL и щелкните на кнопке с текстом - '...' (три точки, Инспектор Объектов - В.О.). Должен появиться диалог редактора списка строк (String List Editor).

  4. Введите: Select * from EMPLOYEE where SALARY>50000. Нажмите OK.

  5. Выберите в Инспекторе Объектов свойство Active и установите его в TRUE.

  6. Разместите на форме объект TDatasource.

  7. Установите свойство Dataset у TDatasource в Query1.

  8. Разместите на форме TDBGrid.

  9. Установите его свойство Datasource в Datasource1.
Свойство SQL имеет тип TStrings. Объект TStrings представляет собой список строк, и чем-то похож на массив. Тип данных TStrings имеет в своем арсенале команды добавления строк, их загрузки из текстового файла и обмена данными с другим объектом TStrings. Другой компонент, использующий TStrings - TMemo. В демонстрационном проекте ENTRSQL.DPR (по идее, он должен находится на отдельной дискетте, но к "Советам по Delphi" она не прилагается - В.О.), пользователь должен ввести SQL-запрос и нажать кнопку "Do It" ("сделать это"). Результаты запроса отображаются в табличной сетке. В Листинге 1 полностью приведен код обработчика кнопки "Do It".

Листинг 1

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
If Memo1.Lines[0] <> '' {Проверяем на предмет пустого ввода} then
Query1.SQL.Add(Memo1.Text) {Назначаем свойству SQL текст Memo}
else
begin
messageDlg('Не был введен SQL-запрос', mtError, [mbOK], 0);
exit;
end;
try        {перехватчик ошибок}
Query1.Open;     {Выполняем запрос и открываем набор данных}
except     {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки}
messageDlg(e.message,
mtError,
[mbOK],0); {показываем свойство message объекта e}
end;      {окончание обработки ошибки}

end;

Свойство Params

Этого должно быть достаточно для пользователя, знающего SQL. Тем не менее, большинство пользователей не знает этого языка. Итак, ваша работа как разработчика заключается в предоставлении интерфейса и создании SQL-запроса. В Delphi, для создания SQL-запроса на лету можно использовать динамические запросы. Динамические запросы допускают использование параметров. Для определения параметра в запросе используется двоеточие (:), за которым следует имя параметра. Ниже приведе пример SQL-запроса с использованием динамического параметра:

          select * from EMPLOYEE
          where DEPT_NO = :Dept_no
Если вам нужно протестировать, или установить для параметра значение по умолчанию, выберите свойство Params объекта Query1. Щелкните на кнопке '...'. Должен появиться диалог настройки параметров. Выберите параметр Dept_no. Затем в выпадающем списке типов данных выберите Integer. Для того, чтобы задать значение по умолчанию, введите нужное значение в поле редактирования "Value".

Для изменения SQL-запроса во время выполнения приложения, параметры необходимо связать (bind). Параметры могут изменяться, запрос выполняться повторно, а данные обновляться. Для непосредственного редактирования значения параметра используется свойство Params или метод ParamByName. Свойство Params представляет из себя массив TParams. Поэтому для получения доступа к параметру, необходимо указать его индекс. Для примера,

Query1.params[0].asInteger := 900;

Свойство asInteger читает данные как тип Integer (название говорит само за себя). Это не обязательно должно указывать но то, что поле имеет тип Integer. Например, если тип поля VARCHAR(10), Delphi осуществит преобразование данных. Так, приведенный выше пример мог бы быть записан таким образом:

Query1.params[0].asString := '900';

или так:

Query1.params[0].asString := edit1.text;

Если вместо номера индекса вы хотели бы использовать имя параметра, то воспользуйтесь методом ParamByName. Данный метод возвращает объект TParam с заданным именем. Например:

Query1.ParamByName('DEPT_NO').asInteger := 900;

В листинге 2 приведен полный код примера.

Листинг 2

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close;     {Деактивируем запрос в качестве одной из мер предосторожности }
if not Query1.prepared
then
Query1.prepare; {Убедимся что запрос подготовлен}
{Берем значение, введенное пользователем и заменяем
им параметр.}
if edit1.text <> '' {Проверяем на предмет пустого ввода}
then
Query1.ParamByName('DEPT_NO').AsString := edit1.text
else
Begin
Query1.ParamByName('DEPT_NO').AsInteger := 0;
edit1.text := '0';
end;
try        {перехватчик ошибок}
Query1.Open;     {Выполняем запрос и открываем набор данных}
except     {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки} messageDlg(e.message,
mtError,
[mbOK],0); {показываем свойство message объекта e}
end;     {окончание обработки ошибки}
end;

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

Источник данных

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

Примечание: Следующий пример использует TTable с именем Table1. Для Table1 имя базы данных IBLOCAL, имя таблицы - DEPARTMENT. DataSource2 TDatasource связан с Table1. Таблица также активна и отображает записи в TDBGrid.

Способ подключения TQuery к TTable - через TDatasource. Есть два основных способа сделать это. Во-первых, разместить код в обработчике события TDatasource OnDataChange. Например, листинг 3 демонстрирует эту технику.

Листинг 3 - Использования события OnDataChange для просмотра дочерних записей

procedure TForm1.DataSource2DataChange(Sender: TObject; Field: TField);
begin
Query1.Close;
if not Query1.prepared
then
Query1.prepare;
Query1.ParamByName('Dept_no').asInteger := Table1Dept_No.asInteger;
try
Query1.Open;
except
On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;

Техника с использованием OnDataChange очень гибка, но есть еще легче способ подключения Query к таблице. Компонент TQuery имеет свойство Datasource. Определяя TDatasource для свойства Datasource, объект TQuery сравнивает имена параметров в SQL-запросе с именами полей в TDatasource. В случае общих имен, такие параметры заполняются автоматически. Это позволяет разработчику избежать написание кода, приведенного в листинге 3 (*** приведен выше ***).

Фактически, техника использования Datasource не требует никакого дополнительного кодирования. Для поключения запроса к таблице DEPT_NO выполните действия, приведенные в листинге 4.

Листинг 4 - Связывание TQuery c TTable через свойство Datasource

Выберите у Query1 свойство SQL и введите:

             select * from EMPLOYEE
             where DEPT_NO = :dept_no
Выберите свойство Datasource и назначьте источник данных, связанный с Table1 (Datasource2 в нашем примере)

Выберите свойство Active и установите его в True

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

Команда Format

Команда Format заменяет параметры форматирования (%s, %d, %n и пр.) передаваемыми значениями. Например,

Format('Select * from %s', ['EMPLOYEE'])

Результатом вышеприведенной команды будет 'Select * from EMPLOYEE'. Функция буквально делает замену параметров форматирования значениями массива. При использовании нескольких параметров форматирования, замена происходит слева направо. Например,

tblName := 'EMPLOYEE';
fldName := 'EMP_ID';
fldValue := 3;
Format('Select * from %s where %s=%d', [tblName, fldName, fldValue])

Результатом команды форматирования будет 'Select * from EMPLOYEE where EMP_ID=3'. Такая функциональность обеспечивает чрезвычайную гибкость при динамическом выполнении запроса. Пример, приведенный ниже в листинге 5, позволяет вывести в результатах поле salary. Для поля salary пользователь может задавать критерии.

Листинг 5 - Использование команды Format для создания SQL-запроса

procedure TForm1.BitBtn1Click(Sender: TObject);
var
sqlString : string; {здесь хранится SQL-запрос}
fmtStr1,
fmtStr2 : string; {здесь хранится строка, передаваемая для форматирования}

begin
{ Создание каркаса запроса }
sqlString := 'Select EMP_NO %s from employee where SALARY %s';

if showSalaryChkBox.checked {Если checkbox Salary отмечен}
then
fmtStr1 := ', SALARY'
else
fmtStr1 := '';
if salaryEdit.text <> '' { Если поле редактирования Salary не пустое }
then
fmtStr2 := salaryEdit.text
else
fmtStr2 := '>0';

Query1.Close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
Query1.SQL.Add(Format(sqlString,[fmtStr1, fmtStr2]));{Добавляем}
{форматированную строку к свойству SQL}

try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки}
messageDlg(e.message, mtError,[mbOK],0);
{показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;

В этом примере мы используем методы Clear и Add свойства SQL. Поскольку "подготовленный" запрос использует ресурсы сервера, и нет никакой гарантии что новый запрос будет использовать те же таблицы и столбцы, Delphi, при каждом изменении свойства SQL, осуществляет операцию, обратную "подготовке" (unprepare). Если TQuery не был подготовлен (т.е. свойство Prepared установлено в False), Delphi автоматически подготавливает его при каждом выполнении. Поэтому в нашем случае, даже если бы был вызван метод Prepare, приложению от этого не будет никакой пользы.

Open против ExecSQL

В предыдущих примерах TQuerie выполняли Select-запросы. Delphi рассматривает результаты Select-запроса как набор данных, типа таблицы. Это просто один класс допустимых SQL-запросов. К примеру, команда Update обновляет содержимое записи, но не возвращает записи или какого-либо значения. Если вы хотите использовать запрос, не возвращающий набор данных, используйте ExecSQL вместо Open. ExecSQL передает запрос для выполнения на сервер. В общем случае, если вы ожидаете, что получите от запроса данные, то используйте Open. В противном случае допускается использование ExecSQL, хотя его использование с Select не будет конструктивным. Листинг 6 содержит код, поясняющий сказанное на примере.

Листинг 6

procedure TForm1.BitBtnClick(sender : TObject)
begin
Query1.Close;
Query1.Clear;
Query1.SQL.Add('Update SALARY from EMPLOYEE ' +
'where SALARY<:salary values (SALARY*(1+:raise)');
Query1.paramByName('salary').asString := edit1.text;
Query1.paramByName('raise').asString := edit2.text;
try
Query1.ExecSQL;
except
On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;

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

3. Компонент TStoredProc

Хранимая процедура представляет собой список команд (SQL или определенного сервера), хранимых и выполняемых на стороне сервера. Хранимые процедуры не имеют концептуальных различий с другими типами процедур. TStoredProc наследуется от TDataset, поэтому он имеет много общих характеристик с TTable и TQuery. Особенно заметно сходство с TQuery. Поскольку хранимые процедуры не требуют возврата значений, те же правила действуют и для методов ExecProc и Open. Каждый сервер реализует работу хранимых процедур с небольшими различиями. Например, если в качестве сервера вы используете Interbase, хранимые процедуры выполняются в виде Select-запросов. Например, чтобы посмотреть на результаты хранимой процедуры, ORG_CHART, в демонстрационной базе данных EMPLOYEE, используйте следующих SQL-запрос:

 Select * from ORG_CHART
При работе с другими серверами, например, Sybase, вы можете использовать компонент TStoredProc. Данный компонент имеет свойства для имен базы данных и хранимой процедуры. Если процедура требует на входе каких-то параметров, используйте для их ввода свойство Params.

4. TDatabase

Компонент TDatabase обеспечивает функциональность, которой не хватает TQuery и TStoredProc. В частности, TDatabase позволяет создавать локальные псевдонимы BDE, так что приложению не потребуются псевдонимы, содержащиеся в конфигурационном файле BDE. Этим локальным псевдонимом в приложении могут воспользоваться все имеющиеся TTable, TQuery и TStoredProc. TDatabase также позволяет разработчику настраивать процесс подключения, подавляя диалог ввода имени и пароля пользователя, или заполняя необходимые параметры. И, наконец, самое главное, TDatabase может обеспечивать единственную связь с базой данных, суммируя все операции с базой данных через один компонент. Это позволяет элементам управления для работы с БД иметь возможность управления транзакциями.

Транзакцией можно считать передачу пакета информации. Классическим примером транзакции является передача денег на счет банка. Транзакция должна состоять из операции внесения суммы на новый счет и удаления той же суммы с текущего счета. Если один из этих шагов по какой-то причине был невыполнен, транзакция также считается невыполненной. В случае такой ошибки, SQL сервер позволяет выполнить команду отката (rollback), без внесения изменений в базу данных. Управление транзакциями зависит от компонента TDatabase. Поскольку транзакция обычно состоит из нескольких запросов, вы должны отметить начало транзакции и ее конец. Для выделения начала транзакции используйте TDatabase.BeginTransaction. Как только транзакция начнет выполняться, все выполняемые команды до вызова TDatabase.Commit или TDatabase.Rollback переводятся во временный режим. При вызове Commit все измененные данные передаются на сервер. При вызове Rollback все изменения теряют силу. Ниже в листинге 7 приведен пример, где используется таблица с именем ACCOUNTS. Показанная процедура пытается передать сумму с одного счета на другой.

Листинг 7

procedure TForm1.BitBtn1Click(Sender: TObject);
{ ПРИМЕЧАНИЕ: Поле BALANCE у ACCOUNTS имеет триггер, проверяющий
ситуацию, когда вычитаемая сумма превышает BALANCE. Если так, UPDATE
будет отменен}
begin
try
database1.StartTransaction;
query1.SQL.Clear;
{ Вычитаем сумму из выбранного счета }
query1.SQL.Add(Format('update ACCOUNTS ' +
'set BALANCE = BALANCE - %s ) ' +
'where ACCT_NUM = %s ',
[edit1.text,
Table1Acct_Num.asString]));
query1.ExecSQL;
query1.SQL.Clear;
{ Добавляем сумму к выбранному счету }
query1.SQL.Add(Format('update ACCOUNTS ' +
'set BALANCE = BALANCE + %s ' +
'where ACCT_NUM = %s ',
[edit1.text,
Table2Acct_Num.asString]));
query1.ExecSQL;
database1.Commit; {В этом месте делаем все изменения}
table1.Refresh;
table2.Refresh;
except
{При возникновении в приведенном коде любых ошибок,
откатываем транзакцию назад}
One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
One : Exception do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
end;
end;

И последнее, что нужно учесть при соединении с базой данных. В приведенном выше примере, TDatabase использовался в качестве единственного канала для связи с базой данных, поэтому было возможным выполнение только одной транзакции. Чтобы выполнить это, было определено имя псевдонима (Aliasname). Псевдоним хранит в себе информацию, касающуюся соединения, такую, как Driver Type (тип драйвера), Server Name (имя сервера), User Name (имя пользователя) и другую. Данная информация используется для создания строки соединения (connect string). Для создания псевдонима вы можете использовать утилиту конфигурирования BDE, или, как показано в примере ниже, заполнять параметры во время выполнения приложения.

TDatabase имеет свойство Params, в котором хранится информация соединения. Каждая строка Params является отдельным параметром. В приведенном ниже примере пользователь устанавливает параметр User Name в поле редактирования Edit1, а параметр Password в поле Edit2. В коде листинга 8 показан процесс подключения к базе данных:

Листинг 8

procedure TForm1.Button1Click(Sender: TObject);
begin
try
With database1 do
begin
Close;
DriverName := 'INTRBASE';
KeepConnection := TRUE;
LoginPrompt := FALSE;
With database1.Params do
begin
Clear;
Add('SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB');
Add('SCHEMA CACHE=8');
Add('OPEN MODE=READ/WRITE');
Add('SQLPASSTHRU MODE=SHARED NOAUTOCOMMIT');
Add('USER NAME=' + edit1.text);
Add('PASSWORD=' + edit2.text);
end;
Open;
end;
session.getTableNames(database1.databasename, '*',
TRUE,
TRUE,
ComboBox1.items);
Except
One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;
end;

Этот пример показывает как можно осуществить подключение к серверу без создания псевдонима. Ключевыми моментами здесь являются определение DriverName и заполнение Params информацией, необходимой для подключения. Вам не нужно определять все параметры, вам необходимо задать только те, которые не устанавливаются в конфигурации BDE определенным вами драйвером базы данных. Введенные в свойстве Params данные перекрывают все установки конфигурации BDE. Записывая параметры, Delphi заполняет оставшиеся параметры значениями из BDE Config для данного драйвера. Приведенный выше пример также вводит такие понятия, как сессия и метод GetTableNames. Это выходит за рамки обсуждаемой темы, достаточно упомянуть лишь тот факт, что переменная session является дескриптором database engine. В примере она добавлена только для "показухи".

Другой темой является использование SQLPASSTHRU MODE. Этот параметр базы данных отвечает за то, как натив-команды базы данных, такие, как TTable.Append или TTable.Insert будут взаимодействовать с TQuery, подключенной к той же базе данных. Существуют три возможных значения: NOT SHARED, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT. NOT SHARED означает, что натив-команды используют одно соединение с сервером, тогда как запросы - другое. Со стороны сервера это видится как работа двух разных пользователей. В любой момент времени, пока транзакция активна, натив-команды не будут исполняться (committed) до тех пор, пока транзакция не будет завершена. Если был выполнен TQuery, то любые изменения, переданные в базу данных, проходят отдельно от транзакции.

Два других режима, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT, делают для натив-команд и запросов общим одно соединение с сервером. Различие между двумя режимами заключаются в передаче выполненной натив-команды на сервер. При выбранном режиме SHARED AUTOCOMMIT бессмысленно создавать транзакцию, использующую натив-команды для удаления записи и последующей попыткой осуществить откат (Rollback). Запись должна быть удалена, а изменения должны быть сделаны (committed) до вызова команды Rollback. Если вам нужно передать натив-команды в пределах транзакции, или включить эти команды в саму транзакцию, убедитесь в том, что SQLPASSTHRU MODE установлен в SHARED NOAUTOCOMMIT или в NOT SHARED.

5. Выводы

Delphi поддерживает множество характеристик при использовании языка SQL с вашими серверами баз данных. На этой ноте разрешите попращаться и пожелать почаще использовать SQL в ваших приложениях. [001356]


Delphi 1

SQL: - сортировка вычисляемого поля

Иногда схема данных требует, чтобы набор данных имел вычисляемый результат. В приложениях Delphi в случае использования SQL это возможно, но эта технология немного разнится в зависимости от используемого типа данных.

Для локального SQL, включая таблицы Paradox и dBASE, вычисляемому полю дают имя с использованием ключевого слова AS. При этом допускается ссылаться на такое поле для задания порядка сортировки с помощью ключевой фразы ORDER BY в SQL-запросе. Например, используя демонстрационную таблицу ITEMS.DB:

  SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
  FROM "ITEMS.DB" I
  ORDER BY TOTAL
В данном примере вычисляемому полю было присвоено имя TOTAL (временно, только для ссылки), после чего оно стало доступным в SQL-запросе для выражения ORDER BY.

Вышеуказанный метод не поддерживается в InterBase. Тем не менее, сортировать вычисляемые поля в таблицах InterBase (IB) или сервере Local InterBase Server все же возможно. Вместо использования имени вычисляемого поля, в выражении ORDER BY используется порядковое число, представляющее собой позицию вычисляемого поля в списке полей таблицы. Например, используя демонстрационную таблицу EMPLOYEE (расположенную в базе данных EMPLOYEE.GDB):

  SELECT EMP_NO, SALARY, (SALARY / 12) AS MONTHLY
  FROM EMPLOYEE
  ORDER BY 3 DESCENDING
В то время, как таблицы IB и LIBS используют второй метод, и не могут воспользоваться первым, оба метода доступны при работе с локальным SQL. К примеру, используя SQL-запрос для таблицы Paradox, и приспосабливая его для работы с относительной позицией вычисляемого поля, а не его именем:
  SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
  FROM "ITEMS.DB" I
  ORDER BY 3
[001358]


SQL: - суммирование вычисляемого поля

Бывают случаи, когда в приложении Delphi, которое для получения доступа к данным использует SQL, необходимо узнать сумму вычисленных данных. Другими словами, необходимо с помощью SQL создать вычисляемое поле и применить к нему функцию SUM.

При выполнении такой операции с SQL-таблицами (например, Local InterBase Server), все достаточно тривиально, и сумма вычисляется простым использованием функции SUM с указанием поля. Например, используя демонстрационную таблицу EMPLOYEE (из базы данных EMPLOYEE.GDB):

  SELECT SUM(SALARY / 12)
  FROM EMPLOYEE
Та же самая методика применима в случае возвращаемого набора данных, в котором значения группируются в другом столбце с помощью утверждения GROUP BY:
  SELECT EMP_NO, SUM(SALARY / 12)
  FROM EMPLOYEE
  GROUP BY EMP_NO
  ORDER BY EMP_NO
Пока SQL базы данных поддерживают суммирование вычисляемых полей, локальный SQL этого делать не будет. Для получения результатов нужны другие методы, например копирование результатов запроса с вычисляемым полем во временную таблицу (как и в случае компонента TBatchMove), и использование компонента TQuery для вычисления суммы данных во временной таблице. [001360]


SQL: - использование функции SUBSTRING

SQL-функция SUBSTRING может использоваться в приложениях Delphi, работающих с запросами к локальной SQL, но она не поддерживается при работе с таблицами InterBase (IB) и Local InterBase Server (LIBS). Ниже приведен синтаксис функции SUBSTRING, примеры ее использования в запросах к local SQL, и альтернатива для возвращения тех же результатов для таблиц IB/LIBS.

Синтаксис функции SUBSTRING:

  SUBSTRING(<column> FROM <start> [, FOR <length>])
Где:

<column> - имя колонки таблицы, из которой должна быть получена подстрока (substring).

<start> место в значении колонки, начиная с которого извлекается подстрока.

<length> длина извлекаемой подстроки.

Функция SUBSTRING в примере ниже возвратит второй, третий и четвертый символы из колонки с именем COMPANY:

  SUBSTRING(COMPANY FROM 2 FOR 3)
Функция SUBSTRING может быть использована и для списка полей в SELECT-запросе, где ключевое слово WHERE допускает сравнение значения с определенным набором колонок. Функция SUBSTRING может использоваться только с колонками типа String (на языке SQL тип CHAR). Вот пример функции SUBSTRING, использующей список колонок в SELECT-запросе (используем демонстрационную таблицу Paradox CUSTOMER.DB):
  SELECT (SUBSTRING(C."COMPANY" FROM 1 FOR 3)) AS SS
  FROM "CUSTOMER.DB" C
Данный SQL-запрос извлекает первые три символа из колонки COMPANY, возвращаемой как вычисляемая колонка с именем SS. Вот пример функции SUBSTRING, использованной в SQL-запросе с ключевым словом WHERE (используем ту же самую таблицу):
  SELECT C."COMPANY"
  FROM "CUSTOMER.DB" C
  WHERE SUBSTRING(C."COMPANY" FROM 2 FOR 2) = "an"
Данный запрос возвратит все строки таблицы, где второй и третий символы в колонке COMPANY равны "ar".

Так как функция SUBSTRING не поддерживается в базах данных IB и LIBS, операции с подстроками со списком колонок в запросе невозможны (исключение: IB может работать с подстроками через функции, определяемые пользователем, User-Defined Functions). Но с помощью оператора LIKE и сопутствующих символьных маркеров подстановки возможно работать с подстрокой и в случае WHERE. Вот пример на основе таблицы EMPLOYEE (в базе данных EMPLOYEE.GDB):

  SELECT LAST_NAME, FIRST_NAME
  FROM EMPLOYEE
  WHERE LAST_NAME LIKE "_an%"
Данный SQL-запрос возвратит все строки таблицы, где второй и третий символы в колонке LAST_NAME равны "an", см. предыдущий пример на основе таблицы Paradox. Базам данных IB и LIBS для выполнения сравнения подстроки в операторе запроса WHERE данный метод необходим (и невозможно воспользоваться функцией SUBSTRING), таблицы же Paradox и dBASE (например, local SQL) могут воспользоваться любым методом. [001362]


Delphi 2

32-битное соединение с сервером Sybase

32-битное соединение с сервером Sybase

Данный документ содержит информацию, позволяющую осуществить подключение к базе данных Sybase через 32-битный пакет от фирмы Borland Sybase SQL Links, поставляемый в составе Delphi 2.x. Клиентское программное обеспечение Sybase займет на вашем жестком диске приблизительно 10+ мегабайт свободного пространства.

Шаги для подключения:

  1. Убедитесь в том, что пакет SQL Links установлен на вашем локальном диске. При полной установке Delphi 2.x это должно быть уже установлено в системе.
  2. Инсталируйте клиентское программное обеспечение Sybase.
  3. При появлявлении в процессе установки диалога выбора 16- и 32-разрядной версии Sybase links, выберите только 32-битную версию (отметьте галочкой) и убедитесь в том, что опция 16-битной версии выключена.
  4. После того, как клиентское программное обеспечение будет установлено на вашем жестком диске, у вас попросят разрешение на автоматическую программную коррекцию вашего файла AUTOEXEC.BAT. Выберите YES.
  5. На запрос по поводу редактирования вашего файла SQL.INI ответьте YES.
  6. В секции "Input Server Name:" (введите имя сервера) укажите псевдоним сервера. Щелкните на кнопке 'Add' (добавить) для внесения имени сервера в список "Server Entry:". Затем убедитесь в том, что поля редактирования "Service Type:" (тип сервиса) (должно быть 'query' (запрос)), "Platform:" (платформа) (по умолчанию обычно устанавливается в NT, dos или Win3), и "Net-Library Driver:" (драйвер сетевой библиотеки) (должен быть NLWNSCK или NLNWLINK) содержат верные сведения. Заполните поле редактирования "Connection Information/Network Address:" (адрес информационного/сетевого соединения), введя сетевой адрес сервера, с которым вы хотите иметь соединение. Щелкните на кнопке 'Add Service' (добавить сервис). Вы можете теперь пропинговать ваш сервер, щелкая по кнопке 'Ping'. Сохраните текущие настройки и выйдите из программы.
  7. Завершите работу Windows и перегрузите машину.
  8. В меню пуск выберите программную группу Delphi и запустите Database Explorer.
  9. В Навигаторе баз данных (Database explorer) щелкните на закладке Database. Активизируйте пункт меню Object | New... В диалоговом окне в выпадающем списке должно стоять имя STANDARD. Щелкните на стрелке и выберите из появившегося списка SYBASE.
  10. Теперь там должен быть псевдоним для вашего соединения с Sybase с именем SYBASE1. Убедитесь в том, что это имя выделено. Щелкните в Database Explorer на следующей закладке. В секции "Server Name" (имя сервера) выберите имя одного из серверов, которые вы поместили в ваш SQL.INI, и который пингуется. В секции "User Name" укажите имя пользователя, имеющего права на доступ к определенному в секции "Server Name" серверу. Убедитесь в том, что вы знаете пароль только что назначенного пользователя.
  11. Дважды щелкните на имене псевдонима (SYBASE1) и в появившемся диалоговом окне введите имя пользователя и его пароль. Имя пользователя должно совпадать с именем, определенным в секции "User Name" для псевдонима Sybase. Введите пароль, соответствующий данному пользователю. Нажмите кнопку OK. Теперь около псевдонима Sybase (SYBASE1) вы должны увидеть иконку, обозначающую маленький зеленый ящик. Это означает успешное установление соединения.
Тестирование вашего соединения с помощью Delphi 2.x:
  1. Разместите на пустой форме компоненты TDataSource, TTable и TDBGrid.
  2. В Инспекторе Объектов (Object Inspector) установите для TDataSource свойство DataSet в 'Table1' (без кавычек).
  3. В Инспекторе Объектов установите для TTable имя базы данных в SYBASE1. Переместитесь ниже до свойства TableName, и дважды щелкните на поле редактирования, расположенного около данного свойства. Должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. При этом должно уже отображаться имя пользователя, которое вы определили в Database Explorer для псевдонима Sybase. Введите соответствующий пароль. Нажмите на кнопку OK.
  4. Теперь вы должны увидеть спискок, состоящий из имен таблиц. Выберите одно.
  5. Щелкните на TDBGrid. Присвойте его свойству DataSource значение DataSource1.
  6. Установите свойство Active компонента TTable в TRUE.
  7. Теперь вы можете увидеть данные в TDBGrid. После запуска приложения должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. Введите пароль и нажмите OK. Теперь вы должны увидеть данные в табличной сетке.
Сообщения об ошибках:

Ошибка, связанная с невозможностью нахождения сетевой библиотеки: Данная ошибка означает, что программе не удалось найти нужную ей .DLL. Следующие файлы должны распологаться в вашем каталоге \Sybase\DLL:

Libblk.dll
Libcomn.dll
Libcs.dll
Libct.dll
Libintl.dll
Libsrv.dll
Libsybdb.dll
Libtcl.dll
Mscvrt10.dll
Nldecnet.dll
Nlmsnmp.dll
Nlnwadvt.exe
Nlnwlink.dll
Nlwnsck.dll
Предостережение: Данный документ не гарантирует установление соединения с сервером, он демонстрирует самый лучший и быстрый способ сделать это.

[001077]


Решение проблемы BDE ~Index out of Date~

Некоторое время назад у меня также была масса ошибок типа 'index out of date' и даже искажение данных. После продолжительного исследования я выяснил причину, она оказалось в различных установках Paradox Language в BDE (v1 и V3) на странице Driver и System в утилите конфигурирования BDE. Я не обратил внимание на установки на странице System одной из рабочих станций, и получил искажение данных.

- Tom Jensen [001017]


Delphi 2

Обратные вызовы BDE32 для получения статуса операций

Тема: Обратные вызовы BDE для получения статуса операций

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

Дополнительная документация, описывающая вызовы функций BDE, находится в файле BDE32.HLP (расположенном в каталоге, где установлен 32-битный IDAPI).

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

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

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

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

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

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

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

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

----- Демонстрационный код ---------

unit Testbc1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, ComCtrls;

type
TForm1 = class(TForm)
Table1: TTable;
BatchMove1: TBatchMove;
Table2: TTable;
Button1: TButton;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Bde; {Здесь расположены Dbi Types и Procs}

{$R *.DFM}

{тип структуры данных для сохранения информации о предыдущем обратном вызове}
type TDbiCbInfo = record
ecbType     : CBType;
iClientData : longint;
DataBuffLn  : word;
DataBuff    : pCBPROGRESSDesc;
DbiCbFn     : pointer;
end;
type PDbiCbInfo = ^TDbiCbInfo;

{Наша функция обратного вызова}
function DbiCbFn(ecbType     : CBType;
iClientData : Longint;
CbInfo      : pointer): CBRType stdcall;
var
s : string;
begin
{Проверяем, является ли тип обратного вызова тем, который мы ожидаем}
if ecbType = cbGENPROGRESS then begin
{если iPercentDone меньше нуля, извлекаем число}
{обработанных записей из параметра szMsg}
if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then begin
s := pCBPROGRESSDesc(cbInfo).szMsg;
Delete(s, 1, Pos(': ', s) + 1);
{Вычислям процент выполненного и изменяем линейку прогресса}
Form1.ProgressBar1.Position :=
Round((StrToInt(s) / Form1.Table1.RecordCount) * 100);
end else
begin
{Устанавливаем линейку прогресса}
Form1.ProgressBar1.Position :=
pCBPROGRESSDesc(cbInfo).iPercentDone;
end;
end;
{существовал ли предыдущий зарегистрированный обратный вызов?}
{если так - осуществляем вызов и возвращаемся}
if PDbiCbInfo(iClientData)^.DbiCbFn <> nil then
DbiCbFn :=
pfDBICallBack(PDbiCbInfo(iClientData)^.DbiCbFn)
(ecbType,
PDbiCbInfo(iClientData)^.iClientData,
cbInfo) else
DbiCbFn := cbrCONTINUE;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
CbDataBuff: CBPROGRESSDesc; {Структура DBi}
OldDbiCbInfo : TDbiCbInfo;  {структура данных должна хранить информацию о предыдущем обратном вызове}
begin
{Убедимся в том, что перемещаемая таблица открыта}
Table1.Open;
{Убедимся в том, что таблица-приемник закрыта}
Table2.Close;
{получаем информацию о любом установленном обратном вызове}
DbiGetCallBack(Table2.Handle,
cbGENPROGRESS,
@OldDbiCbInfo.iClientData,
@OldDbiCbInfo.DataBuffLn,
@OldDbiCbInfo.DataBuff,
pfDBICallBack(OldDbiCbInfo.DbiCbFn));
{регистрируем наш обратный вызов}
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
longint(@OldDbiCbInfo),
SizeOf(cbDataBuff),
@cbDataBuff,
@DbiCbFn);

Form1.ProgressBar1.Position := 0;
BatchMove1.Execute;

{если предыдущий обратный вызов существовал - вновь устанавливаем его,}
{в противном случае "отрегистрируем" наш обратный вызов}
if OldDbiCbInfo.DbiCbFn <> nil then
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
OldDbiCbInfo.iClientData,
OldDbiCbInfo.DataBuffLn,
OldDbiCbInfo.DataBuff,
OldDbiCbInfo.DbiCbFn) else
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
longint(@OldDbiCbInfo),
SizeOf(cbDataBuff),
@cbDataBuff,
nil);

{Показываем наш успех!}
Table2.Open;

end;

end.

[001029]


Управление сетевыми каталогами (BDE)

Если два различных пользователя подключают два различных сетевых каталога (net control directories, NCD), но при этом пути к каталогам одинаковые (это не трудно при работе с сетью), BDE думает, что в этом случае используются одни и те же NCD. Это может привести к _огромным_ проблемам.

Если два пользователя подключают один и тот же NCD, но с разными путями, BDE думает что используются два различных NCD и не позволяет второму пользователю редактировать таблицу. Например, пользователь A подключил NCD по пути G:\DATA\BDENET. Пользователь B подключил NCD по пути H:\BDENET, где H: подключен по пути G:\DATA. В этом случае оба пользователя пытаются использовать один и тот же NCD, но BDE не знает об этом.

Если в вышеприведенном примере пользователи используют один и тот же путь, но с различными буквами диска, BDE позволяет работать обоим пользователям, подразумевая, что они используют один и тот же NCD. Так, если пользователь A подключен к G:\DATA\BDENET, а пользователь B к H:\DATA\BDENET, BDE даст работать обоим.

Это полезно в peer-to-peer сети, где сервер также является и рабочей станцией. В этом случае некоторые (какие?) peer-to-peer OS не позволят серверу подключить сетевой диск к самому себе (я не уверен что у них невозможен эквивалент SUBST, но, по крайней мере, у тех OS, которые я знаю, это отсутствует) так что сервер может использовать только диск C: (или D:, или какой-то другой локальный диск), а рабочая станция нет, поскольку сама имеет собственный локальный диск C:.

Richard Davis

Дополнение от Mark Ostroff (Borland):

В дополнение к ИЗУМИТЕЛЬНОМУ ответу Richard'а, пожалуйста помните об одной ОЧЕНЬ важной вещи... НИКОГДА не допускайте ситуации (в ЛЮБОЙ сети), при которой вы имеете нескольких пользователей, имеющих доступ к одним и тем же таблицам, но использующих разные физические NET-файлы. Это создает ОГРОМНЫЕ проблемы, особенно в в корпоративных и peer-to-peer сетях.

Pdox DOS версии 4.0 использует ту же BDE-схему работы с сетью, что и таблицы Paradox. Необходимо учесть несколько важных моментов:

  1. Убедитесь в том, что у вас включена опция BDE Local Share, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE.
  2. Из-за странного поведения при работе с сетевыми каталогами, пути в файле контроля сети Pdox DOS у ваших пользователей должны быть ИДЕНТИЧНЫ BDE путям (например, тот же каталог И та же буква диска). Это должно быть сделано в случае, если и Pdox DOS, и BDE делают общими одни и те же таблицы и запущены ОБА приложения. Это может создать некоторые проблемы с установкой peer-to-peer сетей.
  3. Убедитесь в том, у вас выключена опция BDE Strict Integrity, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE. В противном случае BDE заблокирует пользователей Pdox DOS для редактирования данных в таблицах Paradox (в любом каталоге), у которых установлена опция целостности данных (Referential Integrity).
  4. Убедитесь в том, что номер версии Paradox, имеющийся в настройках BDE, совместим с OLDEST версией Pdox DOS для использования в вашей сети. Установить ее можно, выбрав соответствующий драйвер Paradox в BDE Config Utility и проверив значение в поле LEVEL. Установите номер версии Pdox DOS, округлив его до ближайшего МЕНЬШЕГО целого числа.
[001035]


Пример DBIDoRestructure

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

function BDEStringFieldResize(ATable: TTable;  AFieldName: string; ANewSize: integer): boolean;
type  TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
var
hDB: hDBIdb;
pTableDesc: pCRTblDesc;
pFldOp: pCROpType;    {фактически это массив array of pCROpType}
pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
CurPrp: CurProps;
CSubType: integer;
CCbrOption: CBRType;
eRestrStatus: TRestructStatus;
pErrMess: DBIMsg;
i: integer;
begin
Result := False;
eRestrStatus := rsFieldNotFound;
AFieldName := UpperCase(AFieldName);
pTableDesc := nil;
pFieldDesc := nil;
pFldOp := nil;

with ATable do
try

{убедимся что имеем исключительный доступ и сохраним dbhandle:}
if Active and (not Exclusive) then Close;
if (not Exclusive) then Exclusive := True;
if (not Active) then Open;
hDB := DBHandle;

{готовим данные для DBIDoRestructure:}
BDECheck(DBIGetCursorProps(Handle,CurPrp));
GetMem(pFieldDesc,CurPrp.iFields*sizeOf(FldDesc));
BDECheck(DBIGetFieldDescs(Handle,pFieldDesc));
GetMem(pFldOp,CurPrp.iFields*sizeOf(CROpType));
FillChar(pFldOp^,CurPrp.iFields*sizeOf(CROpType),0);

{ищем в цикле (через fielddesc) наше поле:}
for i:=1 to CurPrp.iFields do
begin
{для ввода мы имеем серийные номера вместо
Pdox ID, возвращаемых DbiGetFieldDescs:}
pFieldDesc^.iFldNum := i;
if (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName)
and (pFieldDesc^.iFldType = fldZSTRING) then
begin
eRestrStatus := rsNothingToDo;
if (pFieldDesc^.iUnits1 <> ANewSize) then
begin
pFieldDesc^.iUnits1 := ANewSize;
pFldOp^ := crModify;
eRestrStatus := rsDoIt;
end;
end;
inc(pFieldDesc);
inc(pFldOp);
end;  {for}

{"регулируем" массив указателей:}
dec(pFieldDesc,CurPrp.iFields);
dec(pFldOp,CurPrp.iFields);

{в случае отсутствия операций возбуждаем исключение:}
case eRestrStatus of
rsNothingToDo:   raise Exception.Create('Ничего не сделано');
rsFieldNotFound: raise Exception.Create('Поле не найдено');
end;

GetMem(pTableDesc,sizeOf(CRTblDesc));
FillChar(pTableDesc^,SizeOf(CRTblDesc),0);
StrPCopy(pTableDesc^.szTblName,TableName);
{StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
pTableDesc^.szTblType := CurPrp.szTableType;
pTableDesc^.iFldCount := CurPrp.iFields;
pTableDesc^.pecrFldOp := pFldOp;
pTableDesc^.pfldDesc := pFieldDesc;

Close;

BDECheck( DbiDoRestructure(hDB, 1, pTableDesc, nil,  nil,  nil, False) );

finally
if pTableDesc<>nil then
FreeMem(pTableDesc,sizeOf(CRTblDesc));
if pFldOp<>nil then
FreeMem(pFldOp,CurPrp.iFields*sizeOf(CROpType));
if pFieldDesc<>nil then
FreeMem(pFieldDesc,CurPrp.iFields*sizeOf(FldDesc));
Open;
end; {пробуем с table1}
Result := True;
end;

- Reinhard Kalinke [001054]


Delphi 1

Изменение конфигурации IDAPI

Возможно ли установить параметр MAXFILEHANDLES в IDAPI.CFG посредством Delphi?

Да. Следующий компонент показывает как это можно сделать (а также изменить другие параметры):

unit CFGTOOL;

interface

uses SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;

type
TBDEConfig = class(TComponent)
private
FLocalShare : Boolean;
FMinBufSize : Integer;
FMaxBufSize : Integer;
FSystemLangDriver : String;
FParadoxLangDriver : String;
FMaxFileHandles : Integer;
FNetFileDir : String;
FTableLevel : String;
FBlockSize : Integer;
FDefaultDriver : String;
FStrictIntegrity : Boolean;
FAutoODBC : Boolean;

procedure Init;
procedure SetLocalShare(Value : Boolean);
procedure SetMinBufSize(Value : Integer);
procedure SetMaxBufSize(Value : Integer);
procedure SetSystemLangDriver(Value : String);
procedure SetParadoxLangDriver(Value : String);
procedure SetMaxFileHandles(Value : Integer);
procedure SetNetFileDir(Value : String);
procedure SetTableLevel(Value : String);
procedure SetBlockSize(Value : Integer);
procedure SetDefaultDriver(Value : String);
procedure SetAutoODBC(Value : Boolean);
procedure SetStrictIntegrity(Value : Boolean);
procedure UpdateCFGFile( path, item, value : string);

protected

public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property LocalShare : Boolean read FLocalShare write SetLocalShare;
property MinBufSize : Integer read FMinBufSize write SetMinBufSize;
property MaxBufSize : Integer read FMaxBufSize write SetMaxBufSize;
property SystemLangDriver : String
read FSystemLangDriver write SetSystemLangDriver;
property ParadoxLangDriver : String
read FParadoxLangDriver write SetParadoxLangDriver;
property MaxFileHandles : Integer
read FMaxFileHandles write SetMaxFileHandles;
property NetFileDir : String read FNetFileDir write SetNetFileDir;
property TableLevel : String
read FTableLevel write SetTableLevel;
property BlockSize : Integer
read FBlockSize write SetBlockSize;
property DefaultDriver : string
read FDefaultDriver write SetDefaultDriver;
property AutoODBC : Boolean
read FAutoODBC write SetAutoODBC;
property StrictIntegrity : Boolean
read FStrictIntegrity write SetStrictIntegrity;

end;

procedure Register;

implementation

function StrToBoolean( Value : string) : Boolean;
begin
if (UpperCase(Value) = 'TRUE') or
(UpperCase(Value) = 'ON') or
(UpperCase(Value) = 'YES') or
(UpperCase(Value) = '.T.' ) then
Result := True
else
Result := False;
end;

function BooleanToStr( Value : Boolean) : String;
begin
if Value then
Result := 'TRUE'
else
Result := 'FALSE';
end;

procedure Register;
begin
RegisterComponents('Data Access', [TBDEConfig]);
end;

procedure TBDEConfig.Init;
var
h: hDBICur;
pCfgDes: pCFGDesc;
n, v : string;
begin
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,'\SYSTEM\INIT', h));
GetMem(pCfgDes, sizeof(CFGDesc));
try
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'LOCAL SHARE' then
FLocalShare := StrToBoolean(v)
else if n = 'MINBUFSIZE' then
FMinBufSize := StrToInt(v)
else if n = 'MAXBUFSIZE' then
FMaxBufSize := StrToInt(v)
else if n = 'MAXFILEHANDLES' then
FMaxFileHandles := StrToInt(v)
else if n = 'LANGDRIVER' then
FSystemLangDriver := v
else if n = 'AUTO ODBC' then
FAutoODBC := StrToBoolean(v)
else if n = 'DEFAULT DRIVER' then
FDefaultDriver := v;
end;
if (h <> nil) then DbiCloseCursor(h);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,'\DRIVERS\PARADOX\INIT', h));
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'NET DIR' then
FNetFileDir := v
else if n = 'LANGDRIVER' then
FParadoxLangDriver := v;
end;
if (h <> nil) then DbiCloseCursor(h);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,'\DRIVERS\PARADOX\TABLE CREATE', h));
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'LEVEL' then
FTableLevel := v
else if n = 'BLOCK SIZE' then
FBlockSize := StrToInt(v)
else if n = 'STRICTINTEGRITY' then
FStrictIntegrity := StrToBoolean(v);
end;
finally
FreeMem(pCfgDes, sizeof(CFGDesc));
if (h <> nil) then DbiCloseCursor(h);
end;
end;

procedure TBDEConfig.SetLocalShare(Value : Boolean);
begin
UpdateCfgFile('\SYSTEM\INIT','LOCAL SHARE',BooleanToStr(Value));
FLocalShare := Value;
end;

procedure TBDEConfig.SetMinBufSize(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT','MINBUFSIZE',IntToStr(Value));
FMinBufSize := Value;
end;

procedure TBDEConfig.SetMaxBufSize(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT','MAXBUFSIZE',IntToStr(Value));
FMaxBufSize := Value;
end;

procedure TBDEConfig.SetSystemLangDriver(Value : String);
begin
UpdateCfgFile('\SYSTEM\INIT','LANGDRIVER',Value);
FSystemLangDriver := Value;
end;

procedure TBDEConfig.SetParadoxLangDriver(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\INIT','LANGDRIVER',Value);
FParadoxLangDriver := Value;
end;

procedure TBDEConfig.SetMaxFileHandles(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT','MAXFILEHANDLES',IntToStr(Value));
FMaxFileHandles := Value;
end;

procedure TBDEConfig.SetNetFileDir(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\INIT','NET DIR',Value);
FNetFileDir := Value;
end;

procedure TBDEConfig.SetTableLevel(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE','LEVEL',Value);
FTableLevel := Value;
end;

procedure TBDEConfig.SetBlockSize(Value : Integer);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE','BLOCK SIZE',IntToStr(Value));
FBlockSize := Value;
end;

procedure TBDEConfig.SetStrictIntegrity(Value : Boolean);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE','STRICTINTEGRITY',BooleanToStr(Value));
FStrictIntegrity := Value;
end;

procedure TBDEConfig.SetDefaultDriver(Value : String);
begin
UpdateCfgFile('\SYSTEM\INIT','DEFAULT DRIVER',Value);
FDefaultDriver := Value;
end;

procedure TBDEConfig.SetAutoODBC(Value : Boolean);
begin
UpdateCfgFile('\SYSTEM\INIT','AUTO ODBC',BooleanToStr(Value));
FAutoODBC := Value;
end;

procedure TBDEConfig.UpdateCFGFile;
var
h : hDbiCur;
pCfgDes: pCFGDesc;
pPath : array[0..127] of char;
begin
StrPCopy(pPath,Path);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
GetMem(pCfgDes, sizeof(CFGDesc));
try
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
if StrPas(pCfgDes^.szNodeName) = item then begin
StrPCopy(pCfgDes^.szValue,value);
Check(DbiModifyRecord(h,pCfgDes,True));
end;
end;
finally
FreeMem(pCfgDes, sizeof(CFGDesc));
if (h <> nil) then DbiCloseCursor(h);
end;
end;

constructor TBDEConfig.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Init;
end;

destructor TBDEConfig.Destroy;
begin
inherited Destroy;
end;

end.

- Eryk Bottomley [001055]


Default Cursor после завершения выполнения запросов

Тема: Возврат курсора по умолчанию после выполнения запроса

Почему мышиный курсор не возвращается обратно (не становится обычной стрелкой) после выполнения запроса?

При выполнении открытого запроса, Delphi изменяет для вас курсор, и произойти это может даже в середине события, как, например, при нажатии на кнопку. Приведенный ниже пример отобразит курсор в виде иконки песочных часов (SQL Hourglass Icon) после того, как вы закроете окно с сообщением. При этом мышь будет вести себя так, как будто находится в режиме "стрелки".

// Добавьте к обработчику события нажатия кнопки,
// использование запроса при этом не имеет значения
// Select * from Customer (в IBLocal)
with query1 do begin
close;
open;
showmessage(IntToStr(RecordCount));
end; // with

При наступлении события, Delphi пробует обратно придать курсору тип стрелки (Arrow), при этом выводится новая форма (диалог showmessage), которая мешает автоматическому переводу курсора в режим стрелки.

Для решения этой проблемы нужно добавить Application.ProcessMessages прежде, чем форма будет показана, это позволит обработать все сообщения, скопившиеся в очереди (и очистить ее), после чего мышиный курсор вновь пример нормальную форму.

// Добавьте к обработчику события нажатия кнопки,
// использование запроса при этом не имеет значения
// Select * from Customer (в IBLocal)
with query1 do begin
close;
open;
application.ProcessMessages;       // Добавьте эту строку.
showmessage(IntToStr(RecordCount));
end; // with

[001064]


Протокол блокировки BDE

Тема: BDE и Database Desktop Locking Protocol

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

Предварительные условия
Базовые знания или интерес к протоколам блокировки Paradox и форматам таблиц.

Цель
Дать пользователям лучшее понимание протокола блокировки таблицы.

Таблицы, типы полей и поддерживаемые характеристики
Каждый следующий выпуск Paradox, начиная с версии 2.0, содержал улучшения структуры таблицы. Все типы таблиц Paradox, начиная с Paradox 1.0 и заканчивая Paradox 3.5, совместимые друг с другом.

Paradox 4.0 добавляет новый тип данных к формату таблиц: Binary Large Objects (бинарные большие объекты), обычно известные как BLOb'ы, и новые типы вторичных индексов. Paradox 4.0 поддерживает два типа BLOb-полей: Memo и BLOb. Paradox старее версии 4.0 и Engine до версии 3.0 не могут читать, писать и создавать этот новый табличный формат. При попытке чтения или записи таблиц типа Paradox 4.0 более ранней версией Paradox, вы получите ошибку о защите таблицы паролем.

Paradox 5.0 добавляет несколько новых типов данных к формату таблиц: Long Integer, Time, TimeStamp, Logical, Autoincrement, BCD, Bytes. Paradox 7.0 добавляет наследуемый вторичный индекс. Создание или любое изменение таблицы переводит ее формат на новый уровень, включающий все вышеописанные характеристики. По умолчанию создаваемая с использованием Database Desktop или BDE (Borland Database Engine) таблица имеет тип Paradox 4.0. Данный тип, заданный по умолчанию, может быть изменен с помощью утилиты BDE configuration utility или Database desktop configuration utility, и ему может быть присвоен тип Paradox 3, 4, 5 или 7 для BDE.

Paradox 4.0 может читать, писать и создавать таблицы типа Paradox, совместимые с таблицами версий от Paradox 1.0 до Paradox 4.0. Так, таблица, созданая в Paradox 1.0, совместима с Paradox 4.0. Таблица, созданная в Engine 1.0 или 2.0, может быть прочитана и записана в Paradox 4.0.

Paradox и Engine не изменяет тип таблицы при чтении или записи. Тип таблицы изменяется только при ее реструктуризации.

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

Протокол блокировки Database Desktop/ Paradox 4.0
Протокол блокировки Paradox 4.0 - единственный протокол, доступный для Paradox 4.0 и IDAPI Engine. Обозначение "Paradox 4.0 locking protocol" представляет данный стиль блокировки.

Блокировки каталога
Paradox 4.0 располагает файл блокировки, PDOXUSRS.LCK, в каждом каталоге, в котором доступны таблицы. Файл блокировки регулирует доступ к файлам, расположенным в каталоге. Файл блокировки ссылается на PDOXUSRS.NET, поэтому все пользователи должны подключать данные по одному и тому же пути. При этом в каталоге также располагается эксклюзивный файл PARADOX.LCK. Это делается для того, чтобы предохранить те версии Paradox или Engine, которые используют старую блокировочную систему, от неумышленного получения доступа к таблицам.

Рабочие каталоги и каталоги общего доступа
Когда Paradox или Database Desktop необходимо получить доступ к таблицам, расположенным в каталоге, то в этом каталоге они размещают "общий" файл PDOXUSRS.LCK и "эксклюзивный" файл PARADOX.LCK. Этим способом они "метят" каталог для того, чтобы другие пользователи Paradox 4.0 также могли иметь доступ к таблицам, расположенным в данном каталоге. Эксклюзивный файл PARADOX.LCK устанавливается в этом каталоге для обеспечения работы несовместимого протокола блокировки, и, таким образом, для уменьшения риска при постинге данных. В Paradox'е этот каталог известен как рабочий, "Working" каталог.

Частные/эксклюзивные каталоги
Для Paradox и Database Desktop также необходим каталог, где они могли бы сохранять временные файлы, например, результаты запроса. При запуске Paradox или Paradox Runtime, они также размещают в каталоге "эксклюзивные" файлы PDOXUSRS.LCK и PARADOX.LCK, определяя данный каталог как место для хранения временных файлов. Это обозначает, что другие пользователи Paradox не смогут получить доступ к таблицам в этом каталоге. В Paradox'е этот каталог известен как частный, "Private" каталог.

Блокировка таблицы
Paradox 4.0 размещает каждую табличную блокировку в блокирующем файле PDOXUSRS.LCK, располагаемом в каталоге с таблицами. Теперь нет необходимости в использовании отдельного блокирующего файла для каждой таблицы, как это было в предыдущих версиях. Например, если три пользователя просматривают таблицу CUSTOMER.DB и один пользователь реструктуризирует таблицу ORDERS.DB, то файл PDOXUSRS.LCK будет иметь общую блокировку, указывающую на каждого из тех трех пользователей, просматривающих таблицу CUSTOMER.DB, и эксклюзивную блокировку на ORDERS.DB для пользователя, реструктуризирующего таблицу.

Протокол блокировки параллельности Paradox 4.0 (Locking Protocol Concurrency)
В многопользовательской среде протокол блокировки Paradox 4.0 поддерживает параллелизм, т.е. одновременное использование приложений, через файл PDOXUSRS.NET. Все пользователи, которые хотят иметь общий доступ к таблицам Paradox, должны иметь один и тот же путь к файлу PDOXUSRS.NET, но при этом логическая буква сетевого диска может отличаться. Для того, чтобы предотвратить доступ к файлам, расположенным в каталоге, предыдущим версиям, Paradox размещает PDOXUSRS.LCK и эксклюзивный файл PARADOX.LCK в каждом каталоге, где имеются доступные таблицы. Каждый пользователь, который хочет дать общий доступ к таблице в этом каталоге, должен подключить этот каталог с одним и тем же путем, с использованием одного логического сетевого диска и пути. Затем Paradox разместит всю информацию о блокировках для этой таблице в файле PDOXUSRS.LCK, уменьшая этим количество необходимых файлов.

Сетевой управляющий файл (Network Control File)
Сетевой управляющий файл Paradox, PDOXUSRS.NET, служит в качестве контрольной точки для всех блокирующих файлов, создаваемых Paradox. Net-файл содержит список пользователей, в настоящий момент использующих BDE, вместе со списком используемых ими таблиц. Каждый блокирующий файл ссылается на сетевой управляющий файл и содержит информацию о блокировках таблицы и пользователях, заблокировавших эти таблицы, поэтому все пользователи должны иметь один и тот же путь к сетевому управляющему файлу, но при этом логическая буква сетевого диска может отличаться.

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

Если вы подключаете \\SERVER_1\DATA в корень диска P, то каждая система Paradox должна определять расположение PARADOX.NET как P:\PDOXDATA\. Тем не менее, другие пользователи могут подключить \\SERVER_1\DATA к корневому каталогу O и установить O:\PDOXDATA\ как местоположение сетевого управляющего файла.

Конфигурирование 16-битного Database Engine / IDAPI.CFG
Файл конфигурации Database Engine хранит специфическую сетевую информацию, список псевдонимов баз дынных и другую информацию. Вы можете конфигурировать IDAPI с помощью программы конфигурации Database Engine, BDECFG.EXE, и устанавливать с помощью нее месторасположение сетевого управляющего файла. Также возможно добавление, удаление и изменение псевдонимов баз данных (включая информацию об используемом драйвере и типе псевдонима), каким способом IDAPI осуществляет общий доступ к локальным таблицам для программ, использующих протокол блокировки Paradox 4.0, а также некоторые особенности относительно таблиц и способа отображения данных.

Локальные 16-битные установки
Файл WIN.INI содержит путь к файлу IDAPI.CFG, "рабочему" ("Working") каталогу Database Desktop и "частному" ("Private") каталогу Database Desktop. Для изменения этих значений необходимо загрузить файл WIN.INI в любой текстовый редактор и отредактировать его. Путь к файлу IDAPI.CFG описан в группе [IDAPI] как CONFIGFILE=<полный диск, путь и имя файла> или CONFIGFILE01=<полный диск, путь и имя файла>.

Месторасположение "рабочего" ("Working") и "частного" ("Private") каталога Database Desktop описано в группе [DBD] соответственно как WORKDIR=<полный диск и каталог> и PRIVDIR=<полный диск и каталог>.

Конфигурирование 32-битного Database Engine / IDAPI32.CFG
Конфигурационный файл BDE хранит ту же информацию, что и конфигурационный файл Database Engine. Для конфигурирования IDAPI32.CFG используется утилита BDE Configuration, BDECFG32.EXE. Вдобавок к этому, вы можете сохранять информацию в регистрах, или сразу, и в регистрах, и в IDAPI32.CFG.

Локальные 32-битные установки
В регистрах содержится путь к IDAPI32.CFG, к "рабочему" ("Working") и частному ("Private") каталогу. Месторасположение файла IDAPI32.CFG хранится в ключе HKEY_LOCAL_MACHINE\Software\Borland\Database Engine. Значение CONFIGFILE01 содержит данные типа <полный диск, путь и имя файла>.

Месторасположение каталогов BDE "Working" и "Private" хранится соответственно в ключах HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\WorkDir и HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\PrivDir. По умолчанию, данные для каждого каталога хранятся в виде <Полный диск и каталог>.

Доступ к таблицам Paradox
BDE сначала пытается получить доступ к файлу PDOXUSRS.NET. Если файл PDOXUSRS.NET не найден, Paradox создает новый файл PDOXUSRS.NET и продолжает процедуру запуска. Если файл PDOXUSRS.NET присутствует, но владелец этого net-файла использует другой путь, т.е. подключил сервер иначе, возникает исключительная ситуация "Multiple net files in use" (Используются несколько net-файлов) и BDE прекращает свою работу. После того, как сеть успешно открыла эксклюзивную блокировку, PARADOX.LCK размещается во временном, частном каталоге. При невозможности установки блокировки, BDE прекращает свою работу. Причина неудачи может заключаться в том, что какой-то пользователь имеет в этом каталоге эксклюзивную блокировку, или же файлы блокировки используют различные net-файлы. После того, как каталог будет защищен от частного использования, общий файл PARADOX.LCK будет расположен в рабочем каталоге, и на этом процесс инициализации будет завершен.

[001089]


Я так и не смог заставить выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки

Nomadic отвечает:

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

set serveroutput on size 10000;
[001236]


После analyze_schema некоторые (приличное количество) из запросов начинают сильно тормозить. Как лечить?

Nomadic отвечает:

Это у всех так или у воркгрупп 7.3.2 под HТ только? Пока полечил удалением статистики. Хинтить не предлагайте, запросы генерит crystal report, а он очень трепетно относится к редактированию sql-предложения в некоторых местах...

А ты метод оптимизатора по дефолту переключи в RULE. Это можно сделать разными способами :

  1. ALTER SESSION SET OPTIMIZER_GOAL = ... (это только для данной сессии)
  2. При старте инстанса поправить параметр OPTIMIZER_MODE (это для всех сессий)
[001240]


Delphi 1

Определение установленной BDE

Для Delphi 2 проверьте регистрацию в ключе регистра

  HKEY_LOCAL_MACHINE\Software\Borland\Database Engine
Для Delphi 1 проверьте в файле Win.INI секцию с именем IDAPI
[IDAPI]
DLLPATH=3DD:\WINPROG\DELPHI\IDAPI
CONFIGFILE01=3DD:\WINPROG\DELPHI\IDAPI\IDAPI.CFG
Хотя это и не лучший путь, поскольку пользователь может удалить BDE, а регистры или INI-файл будут хранить эту информацию. [001260]


Delphi 1

Установка BDE

Вот имена файлов, которые вам нужно установить в рантайме:

Borland Database Engine
Уникальный файл на BDE Disk #1
Имя файла :- IDAPICFG.PAK
Устанавливаемый Exe :-Setup.exe

Borland SQL Links
Уникальный файл на SQL Disk #1
Имя файла :- MNOVLWP.PAK
Устанавливаемый Exe :-Setup.exe

Borland ReportSmith Runtime
Уникальный файл на RPT Disk #1
Имя файла :- INSTXTRA.PAK
Устанавливаемый Exe :-Setup.exe
Borland настоятельно рекомендует при установке рантайм-версий пользоваться программами установки. [001289]


Каковы текущие ограничения BDE?

Nomadic отвечает:

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

Основные ограничения BDE:

  • 48 клиентов в системе;
  • 32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit)
  • 32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit)
  • 32 загруженных драйвера
  • 64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit)
  • 12288 сессии в системе (для версии 4.0 и выше, 32 Bit)
  • 4000 курсоров на сессию
  • 16 вхождений в стеке ошибок
  • 8 типов таблиц на один драйвер
  • 16 типов полей на один драйвер
  • 8 типов индексов на один драйвер
  • 48K Размер конфигурационного файла (IDAPI.CFG)
  • 64K Максимальный размер оператора SQL при RequestLive=False
  • 4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit)
  • 6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit)
  • 16K Размер буфера записи (SQL и ODBC)
  • 31 Размер имени таблицы и имени поля в символах
  • 64 Размер имени хранимой процедуры в символах
  • 16 Полей в ключе
  • 3 Размер расширения имени файла в символах
  • 260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения)
  • 260 Длина полного имени файла и пути файловой системы в символах

    Ограничения Paradox:

  • 127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit)
  • 254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit)
  • 64 блокировки на запись на одну таблицу (16Bit) на одну сессию
  • 255 блокировок на запись на одну таблицу (32Bit) на одну сессию
  • 255 записей, учавствующих в транзакции на таблицу (32 Bit)
  • 512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit)
  • 1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit)
  • 300 пользователей в одном файле PDOXUSRS.NET
  • 255 полей в таблице
  • 255 размер символьных полей
  • 2 миллиарда записей в таблице
  • 2 миллиарда байт в .DB (таблица) файле
  • 10800 байт на запись для индексированных таблиц
  • 32750 байт на запись для неиндексированных таблиц
  • 127 вторичных индексов на таблицу
  • 16 полей на индекс
  • 255 одновременно работающих пользователей на таблицу
  • 256 Мегабайт данных на одно BLOb поле
  • 100 паролей на сессию
  • 15 длина пароля
  • 63 паролей на таблицу
  • 159 полей с проверками корректности (validity check) (32 Bit)
  • 63 поля с проверками корректности (validity check) (16 Bit)

    Ограничения dBase:

  • 256 открытых таблиц dBASE на систему (16 Bit)
  • 350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit)
  • 512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit)
  • 100 блокировок на запись на одной таблице dBASE (16 and 32 Bit)
  • 100 записей, учавствующих в транзакции на таблицу (32 Bit)
  • 1 миллиард записей в таблице
  • 2 миллиарда байт в файле .DBF (таблица)
  • 4000 Размер записи в байтах (dBASE 4)
  • 32767 Размер записи в байтах (dBASE for Windows)
  • 255 Количество полей в таблице (dBASE 4)
  • 1024 Количество полей в таблице (dBASE for Windows)
  • 47 Количество тэгов индексов на один .MDX-файл.
  • 254 Размер символьных полей
  • 10 открытых основных индексов (.MDX) на таблицу
  • 220 Длина ключевого выражения в символах [001307]


В процессе работы программы изменилась структура БД (alter table etc.). Программа продолжала успешно открывать таблицы, но запросы посылались в соответствии со старой схемой данных

Nomadic отвечает:

В установках BDE (Configuration utility или BDEAdmin) можно выставить SCHEMA CACHE = FALSE (не кэшировать схему данных).

Но в некоторых случаях ошибки такого рода все-таки происходят. В таком случае необходимо воспользоваться методом TDatabase.FlushSchemaCache после каждого изменения метаданных. [001315]


Как в Delphi сбросить кэш БД на диск?

Nomadic отвечает:

uses BDE {в Delphi 1.x не помню, но вроде bdeprocs};

dbiSaveChanges

На Delphi 1.x (16bit) дополнительно вызовите эту процедуру -

procedure DropCache; assembler;
asm
mov ah,$0D
int $21
 end;

[001317]


Как настроить MS SQL Server 6.5 на корректную работу с числами и BDE при выполнении UPDATE?

Nomadic отвечает:

Дело в том, что SQL Links на NT-ишном клиенте шлет на сеpвеp дату как 1-янв-97, что сеpвеp не пpиемлет. Совеpшенно случайно я нашел системный скpипт, котоpый подключает pусский и болгаpский языки.

  1. выполни sp_configure и убедись, что у тебя default sortorder id==106 (rus case insens) или 105 (rus case sens). Если нет - пеpеставь сеpвеp.

  2. найди в каталоге c:\mssql\install скpипт instlang.sql и запусти его.

  3. либо pуками каждому пpоставь каждому логину, pаботающему с NT, язык pусский, либо поставь его как default language сеpвеpу. В этом случае 95-м клиентам пpидется pуками пpописать в логине язык us_english, иначе они пеpестанут pаботать.
Для установки russian как default надо выполнить скpипт:
exec sp_configure 'default language', 2
go
reconfigure
go
[001365]


Как научить VCL делать Refresh для запросов правильно?

Особенно интересует Refresh для связки Master-Detail.

Nomadic отвечает:

Старо как мир, и нет ничего военного:

procedure RefreshQuery( Query: TQuery; F: boolean );
var
B: TBookMark;
begin
with Query do
if Query.Active then
begin
B := GetBookMark;
try
Close;
Unprepare; {Если не поставить этого, то если используется select
SP, то иногда последующая операция вешает сервер.
Кто скажет почему?!}
 Active:=True;
if F then
begin
try
GotoBookMark(B)
except
on EDatabaseError do First;
end
end
else First;
finally
FreeBookmark(B);
end;
end;
end;

Уфф! Кажется, лyчше yже не сделать. :)

dbtables можно опционально пpопатчить (см. в конце), чтобы иметь такой вот pyлезный Detail query.

Update for dbtables.pas

New interface function DoRefreshQuery can Refresh TQuery component in master-detail scheme and alone.

TQuery.RefreshParams should be updated

function GetFieldNamesStr( DataSet: TDataSet ): String;
var
I: Integer;
begin
Result := '';
with DataSet do
for I := 0 to FieldCount - 1 do
begin
Result := Result + Fields[ I ].FieldName + ';';
end;
end;
procedure DoRefreshQuery( Query: TQuery; KeyFields: String; BookMarkSearch: Boolean);
var
Fields: TList;
KeyValues: Variant;
KeyNames: String;
Bmk: TBookmark;
I: Integer;
BookmarkFound: Boolean;
CanLocate: Boolean;
begin
Fields := TList.Create;
if KeyFields = '' then KeyFields := GetFieldNamesStr( Query );
try
Query.GetFieldList( Fields, KeyFields );
for I := Fields.Count - 1 downto 0 do
with TField( Fields[I] ) do
if Calculated or Lookup then Fields.Delete( I );
CanLocate := Fields.Count > 0;
if CanLocate then
begin
if Fields.Count = 1 then
KeyValues := TField(Fields[0]).Value
else
begin
 KeyValues := VarArrayCreate( [0, Fields.Count - 1], varVariant );
KeyValues[0] := TField( Fields[0] ).Value;
end;
KeyNames := TField( Fields[0] ).FieldName;
for I := 1 to Fields.Count - 1 do
begin
KeyNames := KeyNames + ';' + TField( Fields[I] ).FieldName;
KeyValues[ I ] := TField( Fields[I] ).Value;
end;
end;
finally
Fields.Free;
end;
with Query do
begin
Bmk := nil;
DisableControls;
try
BookmarkFound := False;
if BookMarkSearch then
Bmk := GetBookmark;
Close;
Open;
if Assigned( Bmk ) then
try
GotoBookMark( Bmk );
BookmarkFound := True;
except
end;
if not BookmarkFound and CanLocate then
Locate( KeyNames, KeyValues, [] );
finally
EnableControls;
Screen.Cursor := crDefault;
FreeBookmark( Bmk );
end;
end;
end;

procedure TQuery.RefreshParams;
var
DataSet: TDataSet;
begin
DisableControls;
try
if FDataLink.DataSource <> nil then
begin
DataSet := FDataLink.DataSource.DataSet;
if DataSet <> nil then
if DataSet.Active and ( DataSet.State <> dsSetKey ) then
DoRefreshQuery( Self, GetFieldNamesStr( Self ), False );
end;
finally
EnableControls;
end;
end;

[001367]


Как заставить BDE сохранять в БД поле времени с сотыми долями секунды?

Nomadic отвечает:

Если руками, то в BDE Administrator (BDE Configuration Utility).

Если при инсталляции твоей программы, то -
В пункте Make Registry Changes InstallShield'а создай ключ

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE
[001383]


Delphi 1

Запись буфера BDE на диск

Общее:

Сделанные в таблице изменения непосредственно на диск не записываются до тех пор, пока таблица не будет закрыта. Потеря питания или сбой в системе может привести к потере данных и прочим неприятностям. Чтобы избежать этого, существует два прямых вызова Database Engine, дающих один и тот же результат. Эти функции - DbiUseIdleTime и DbiSaveChanges.

DbiSaveChanges(hDBICur):

DbiSaveChanges сохраняет на диске все обновления, находящиеся в буфере таблицы, связанной с курсором (hDBICur). Может быть вызвана из любого места программы. Например, можно при каждом обновлении записи сохранять на диске все изменения (добавьте dbiProcs в список используемых модулей):

procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.handle);
end;

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

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

Эта функция не применима к таблицам SQL.

DbiUseIdleTime:

DbiUseIdleTime может быть вызвана, если "Windows Message Queue" (очередь запросов Windows) пуста. Это позволяет Database Engine сохранить на диске "грязные буферы". Другими словами, выполняется операция DbiSaveChanges, но применительно ко ВСЕМ измененным таблицам. Тем не менее, данная операция не обязательно должна выполняться после каждого обновления записи, ее нужно приберечь для "холостого" периода (период простоя, idle).

В Delphi это может быть использовано таким образом (добавьте dbiProcs в список используемых модулей):

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.onIdle := UseIdle;
end;

procedure Tform1.UseIdle(Sender: TObject; var Done: Boolean);
begin
DbiUseIdleTime;
end;

Некоторые замечания:

Использование обоих вызовов DbiUseIdleTime и DbiSaveChanges (после каждого обновления записи) излишне и сопровождается необязательными вызовами функций. Если приложение выполняет множественный ввод новых записей или их редактирование в течение небольшого периода времени, рекомендуем осуществлять вызов функции DbiUseIdleTime во время простоя клинта, а вызов DbiSaveChanges после осуществления "пакета" обновлений.

В случае, если в таблице выполняется не слишком много изменений, клиент может использовать вызов DbiSaveChanges после каждого постинга или же "повесить" на таймер вызов DbiUseIdleTime. [001386]


письмо читателя

Я переписываю BDE-приложение на другой компьютер, а оно отказывается работать. Что делать?

На этот вопрос отвечает Nomadic:

  1. Использовать инсталляционный пакет, например InstallShield или Wise.
  2. Hе использовать его. В этом случае нет универсального решения. Оно будет варьироваться в зависимости от использования BDE в локальном или серверном режиме, для доступа к Paradox- или DBF-таблицам, использования локального SQL, версии BDE, и так далее... Здесь приведен пример для наиболее общего варианта - пятая версия BDE, локальные таблицы, без использования локального SQL, стандартная кодировка ANSI:

    Hужно добавить следующие файлы из папки BDE к вашему исполняемому модулю:

    blw32.dll, idapi32.dll, idr20009.dll, idpdx32.dll для Paradox-таблиц или iddbas32.dll для DBF-таблиц, bantam.dll, charset.cvb, usa.btl

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

    Приготовленный таким образом дистрибутив запускается на любой машине без необходимости инсталляции BDE, максимально устойчив и нечувствителен к смене имен папок/переинсталляции системы/порчи реестра/влиянии на другие BDE-приложения. Добавка к основному модулю составляет для этих семи dll-библиотек ~1030 КБ, после упаковки ~470 КБ.

[001629]


UUE кодирование

Sergei Dubarev пишет:

Ваши "Советы..." - классная штука. Столько всего вкусного! :-) Со своей стороны хочу предложить несколько тормозной и местами упрощенный, но все же рабочий ;), алгоритм UUE кодирования (см. аттач). Не вершина искусства, но все же... :)

Для того, чтобы ОНО заработало, необходимо создать проект в составе:

  1. Форма (form) - 1 шт.
  2. Поле ввода (edit) - 2 шт., используются события OnDblClick.
  3. Кнопка (button) - 1 шт., используется событие OnClick.
  4. Диалог открытия файла (Open Dialog) - 1 шт.
  5. Диалог сохранения файла (Save Dialog) - 1 шт.
Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE."

Всего хорошего.

P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.

P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.

Файл Unit1.pas

//UUE кодирование
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtDlgs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure Edit1DblClick(Sender: TObject);
procedure Edit2DblClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const
ssz = (High(Cardinal) - $F) div sizeof(byte);
//эта константа используется при выделении памяти

p:    string= '0123456789ABCDEF';
//эта константа используется функцией toanysys

//выбор входного файла
procedure TForm1.Edit1DblClick(Sender: TObject);
begin
if opendialog1.execute then edit1.text:= opendialog1.filename;
end;

//выбор выходного (UUE) файла
procedure TForm1.Edit2DblClick(Sender: TObject);
begin
if savedialog1.execute then edit2.text:= savedialog1.filename;
end;

//выделение подстроки
function mid(s: string; fromc, toc: byte): string;
var s1: string;
i : byte;
begin
s1:= '';
for i:= fromc to toc do s1:= s1+s[i];
mid:= s1;
end;

//перевод числа (a) из десятичной системы в другую
//с основанием (r)
 function toanysys(a, r: byte): string;
var s,
k : string;
n,
m,
i : byte;
begin
s:='';
m:= 1;
while m<>0 do
begin
m:= a div r;
n:= a-m*r+1;
k:= p[n];
s:= k+s;
a:= m;
end;
//добавляет незначащие нули
for i:=1 to 8-length(s) do s:='0'+s;
toanysys:= s;
end;

//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов
 function frombin(s: string): byte;
var i,
e,
b: byte;
begin
b:= 0;
for i:=1 to 6 do
begin
e:= 1 shl (6-i);
if s[i]='1' then b:= b+e;
end;
frombin:= b;
end;

//непосредственно кодирование
 type tcoola = array [1..1] of byte;
pcoola = ^tcoola;

procedure TForm1.Button1Click(Sender: TObject);
var inf: file of byte;
ouf: textfile;
uue: pcoola;
b  : array[1..4] of byte;
bin,
t  : string;
szf,
oum,
szl,
szh,
sxl,
sxh,
i  ,
j  : longint;
begin
{$I-}
assignfile(inf, edit1.text); //входной файл
reset(inf);
szf:= filesize(inf);    //
szh:= (szf*8) div 6;    //
if szf*8-szh*6 = 0 then szl:= 0 else szl:= 1;      //
getmem(uue, szh+szl); //выделение памяти
oum:= 1;
while not(eof(inf)) do
begin
b[1]:= 0;
b[2]:= 0;
b[3]:= 0;
b[4]:= 0;
//чтение должно быть сделано посложнее,
//дабы избежать "read beyond end of file"
read(inf, b[1], b[2], b[3]);
//читаем 3 байта из входного файла
//и формируем "двоичную" строку
bin:= toanysys(b[1],2)+
toanysys(b[2],2)+
toanysys(b[3],2);
//разбиваем строку на куски по 6 бит и добавляем 32
t:= mid(bin, 19, 24);
b[4]:= frombin(t)+32;
t:=mid(bin, 13, 18);
b[3]:= frombin(t)+32;
t:= mid(bin, 07, 12);
b[2]:= frombin(t)+32;
t:= mid(bin, 01, 06);
b[1]:= frombin(t)+32;
//запихиваем полученнные байты во временный массив
uue[oum]:= b[1];
oum:= oum+1;
uue[oum]:= b[2];
oum:= oum+1;
uue[oum]:= b[3];
oum:= oum+1;
uue[oum]:= b[4];
oum:= oum+1;
end;
//входной файл больше не нужен - закрываем его
closefile(inf);
//формируем выходной файл
assignfile(ouf, edit2.text); //выходной файл
rewrite(ouf);
oum:= 1;
sxh:= (szh+szl) div 60; //число строк в UUE файле
sxl:= (szh+szl)-sxh*60;
//заголовок UUE-файла
writeln(ouf, 'begin 644 '+extractfilename(edit1.text));
//записываем строки в файл
for i:=1 to sxh do
begin
write(ouf, 'M');
// 'M' значит, что в строке 60 символов
for j:= 1 to 60 do
begin
write(ouf, chr(uue[oum]));
oum:= oum+1;
end;
writeln(ouf);
end;
//записываем последнюю строку, которая
//обычно короче 60 символов
sxh:= (sxl*6) div 8;
write(ouf, chr(sxh+32));
for i:= 1 to sxl do
begin
write(ouf, chr(uue[oum]));
oum:= oum+1;
end;
// "добиваем" строку незначащими символами
for i:= sxl+1 to 60 do write(ouf, '`');
//записываем последние строки файла
writeln(ouf);
writeln(ouf, '`');
writeln(ouf, 'end');
closefile(ouf);
freemem(uue, szh+szl); //освобождаем память
showmessage('DONE.'); //Готово. Забирайте!
end;

end.

Из FIDO-переписки:

- New auto-created HomeNet area (555:172/89.2) ------------- HOME.PROGRAMMERS -
 Msg  : 34 of 35
 From : Philip Bondarovich                  555:172/445.43  Пнд 17 Янв 00 02:51
 To   : Denis Guravski                                      Втp 18 Янв 00 22:21
 Subj : UUE
-------------------------------------------------------------------------------
 Wednesday January 12 2000 22:56, Denis Guravski писал All:
 DG>  Люди , сpочно нyжно описание сабжа .

=== Begin uuecode ===
- INT.PROGRAMMERS (256:172/43) ------------------------------ INT.PROGRAMMERS -
 Msg  : 38 of 38 -36                        Scn
 From : Monk                                256:172/10      15 Jan 00  18:24:30
 To   : Nikolay Severikov                                   16 Jan 00  03:47:50
 Subj : UU-code
-------------------------------------------------------------------------------

                      Жывi сабе памаленькy, /_*Nikolay*_/!

У чацьвэp Стyдзеня 13 2000 y 23:25, цёмнай ночкаю, Nikolay Severikov тайна
пiсаў All, i я ўцягнyўся...

 NS>   Расскажите плиз о сyбже... Как он кодиpyется.

Калi ласка.
=== Cut ===
1) Читаем из исходного хфайла 3 байта.
2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит.
3) Добавляем к каждой части число 32 (десятичн.)

Пpимеp: Имеем тpи числа 234 12 76. Побитово бyдет так -

11101010 00001100 01001100 pазбиваем и полyчаем -

 111010  100000  110001  001100 добавляем 32 -
+100000 +100000 +100000 +100000
 ------  ------  ------  ------
1011010 1000000 1010001  101100 или в бyквах -
   Z       @       Q       ,

Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных
символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во.
Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения
60
символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит

бyква "M", а ее ASCII код = 77. 45+32=77.
=== Cut ===

З павагай да ўсiх вас, Monk.    Спадзяюся на пpацяг pазмовы, *Nikolay*!

... -Папа, я есть хочy! -Стыдись, сынок, в твои годы я хотел стать космонавтом!
-+- GoldED+/386 1.1.1.2
 + Origin: - Тавеpна BBS - 241-5714 23:00-6:00. Freqs allowed. (256:172/10)

=== End uuecode ===

WBR.

... Чешиpский Котенок лyчше всех
--- GoldED+/W32 1.1.1.2
 * Origin: WonderLand (555:172/445.43)
[001078]


Почему мои ISAPI-ориентированные библиотеки, созданные в Delphi 3, не могут обрабатывать несколько соединений?

Nomadic отвечает:

Волшебник по созданию ISAPI DLL в Delphi 3 создает полностью безопасную многопоточную библиотеку, но не выставляет флаг, говорящий приложению, что эта библиотека в этом отношении безопасна. Это легко исправить, просто добавив строчку:

IsMultiThread := TRUE;
end;

первой строкой в Вашем блоке begin-end файла проекта (DPR). [001448]


Проверка URL

The_Sprite отвечает:

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

URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://

Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

Платформа: Delphi 3.x (или выше)

uses wininet;
Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if pos('http://',lowercase(url))=0 then
url := 'http://'+url;
Result := false;
hSession := InternetOpen('InetURL:/1.0',
INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
if assigned(hsession) then
begin
hfile := InternetOpenUrl(
hsession,
pchar(url),
nil,
0,
INTERNET_FLAG_RELOAD,
0);
dwIndex  := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
@dwcode,
dwcodeLen, dwIndex);
res := pchar(@dwcode);
result:= (res ='200') or (res ='302');
if assigned(hfile) then
InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;

end;

[001377]


Dialer

Nomadic предлагает следующий код:

Function DialProvider(connection:string):boolean;
// connection - имя учетной записи
var pars:TRasDialParams;
hRas:ThrasConn;
r:integer;
begin
hRas:=0;
strpcopy(pars.szEntryName,connection); // имя учетной записи
pars.szPhoneNumber:='';                // номеp телефона - по умолчанию
pars.szcallbacknumber:='';             // callback нам не нужен
pars.szUserName:='';                   // логин - по умолчанию
pars.szPassWord:='';                   // паpоль - по умолчанию
pars.szDomain:='';                     // аналогично с домейном
pars.dwSize:=Sizeof(TRasDialParams);   // вычисляем pазмеp записи
r:=rasdial(nil,nil,pars,0,nil,hRas);   // звоним
if r<>0 then begin                          // если что-то неполучилось, то
rasHangUp(hRas);               // сбpасываем соединение
result:=false;                 // ф-ция тепеpь веpнет false
end
else result:=true;          // а если все ок - то true.
end;

P.S. Ras.pas бpать с www.torry.ru [001739]


Как можно определить, что компьютер подключен к Интернету?

Своим опытом делится Олег Кулабухов:

Положить компонент TCP на форму и

How can I tell at runtime if I am connected to the internet?

Answer:
You can use the TCP component to retrieve the Local IP address. If it is "0.0.0.0" then there is no connection.

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
if TCP1.LocalIp = '0.0.0.0' then
ShowMessage('Your not connected!');
end;

[001856]


Delphi 2

Объект DocInput

Тема: Объект DocInput: свойства и методы

Объект DocInput - объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он предназначен для описания входной информции для документа, передаваемого элементу управления. Все элементы управления для работы с Интернетом, имеющиеся в данном пакете, имеют доступ к объекту через соответствующее свойство, могут хранить в нем документы и передавать его от одного элемента управления другому. Объект DocInput имеет следующие свойства:

BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspended.

BytesTotal - счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных - Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи.

Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому.

Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах.

Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''.

Свойство Headers является свойстом только для чтения и времени выполнения. "headers" - коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола:

  1. content-type (тип содержимого)
    content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain".
  2. content-length (размер содержимого)
    content length указывает размер документа в байтах.

Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput.

Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается.

Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию - False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным.

Объект DocInput имеет 4 метода: GetData, PushStream, SetData и Suspend.

Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи. Метод PushStream может быть вызван только если PushStreamMode установлен в True и когда данные доступны. PushStream устанавливает свойство State на основе следующего шага передачи документа и активизирует в нужный момент событие DocInput. Затем происходит возврат до следующего вызова PushStream. Перед вызовом PushStream должен быть вызван SetData.

Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant.

Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False.

Вот некоторый код примера, показывающий как можно использовать объект DocInput. Полный проект, содержащий данный код, вы можете найти в подкаталоге demos на CD-ROM с Delphi 2.01. Имя проекта SimpMail.dpr. Данные проект представляет собой большое пример использования свойтсва объекта headers. Также показано соответствующее использование события DocInput и свойства State.

{Очистка и новое заполнение заголовков MIME с помощью свойства компонента DocInput. Может также использоваться отдельный OLE объект DocInput. Для получения полной информации о типах MIME смотри документ RFC1521/1522.}

procedure TMainForm.CreateHeaders;
begin
with SMTP1 do
begin
DocInput.Headers.Clear;
DocInput.Headers.Add('To', eTo.Text);
DocInput.Headers.Add('From', eHomeAddr.Text);
DocInput.Headers.Add('CC', eCC.Text);
DocInput.Headers.Add('Subject', eSubject.Text);
DocInput.Headers.Add('Message-Id', Format('%s_%s_%s',
[Application.Title,DateTimeToStr(Now), eHomeAddr.Text]));
DocInput.Headers.Add('Content-Type',
'TEXT/PLAIN charset=US-ASCII');
end;
end;

{Посылаем простое почтовое сообщение}
procedure TMainForm.SendMessage;
begin
CreateHeaders;
with SMTP1 do
SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
end;

{Посылаем файл, расположенный на диске. Оставляем пустым параметр SendDoc InputData и определяем имя файла для InputFile для посылки содержимого файла, расположенного на диске. Для осуществления собственного кодирования (Base64, UUEncode и др.), вы можете использовать событие DocInput и методы GetData }

procedure TMainForm.SendFile(Filename: string);
begin
CreateHeaders;
with SMTP1 do
begin
DocInput.Filename := FileName;
SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
end;
end;

{Событие DocInput возникает при каждом изменении состояния DocInput во время передачи почтового сообщения. DocInput хранит всю информацию о текущей передаче, включая заголовки, количество переданных байт и сами данные сообщения. Хотя в этом примере и не показано, для кодирования данных перед отправкой каждого блока вы можете вызвать метод DocInput SetData, если DocInput.State = icDocData. }
procedure TMainForm.SMTP1DocInput(Sender: TObject;
const DocInput: Variant);
begin
case DocInput.State of
icDocBegin:
SMTPStatus.SimpleText := 'Начало передачи документа';
icDocHeaders:
SMTPStatus.SimpleText := 'Посылаем заголовки';
icDocData:
if DocInput.BytesTotal > 0 then
SMTPStatus.SimpleText :=
Format('Послано данных: %d из %d байт (%d%%)',
[Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal),
Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])
else
SMTPStatus.SimpleText := 'Посылка...';
icDocEnd:
if SMTPError then
SMTPStatus.SimpleText := 'Передача прервана'
else
SMTPStatus.SimpleText := Format('Почта послана %s
(%d байт данных)',
[eTo.Text,Trunc(DocInput.BytesTransferred)]);
end;
SMTPStatus.Update;
end;

[001071]


Delphi 2

Объект DocOutput

Тема: Объект DocOutput: свойства и методы

Объект DocOutput - объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он описывает выходную информацию передаваемого документа. Все элементы управления, имеющие свойство DocOutput, используют этот тип. Он также является объектом, на который указывает событие DocOutput. Объект DocOutput имеет следующие свойства:

BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspend.

BytesTotal - счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных - Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи.

Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому.

Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах.

Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''.

Свойство Headers является свойстом только для чтения и времени выполнения. "headers" - коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола:

  1. content-type (тип содержимого)
    content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain".
  2. content-length (размер содержимого)
    content length указывает размер документа в байтах.
Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput.

Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается.

Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию - False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным.

Объект DocOutput имеет три метода: GetData, SetData и Suspend.

Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи.

Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant.

Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False.

Приведенный здесь код взят из демонстрационного проекта, расположенного в подкаталоге Delphi 2.01 demos\internet. Имя проекта HTTPDemo.dpr. Данный проект представляет собой пример использования свойств объекта BytesTransferred и state. Также показано использование различных типов данных, являющимися новыми для Delphi 2.01. Эти типы данных важны для использования OLE, и пользователи Delphi должны о них узнать как можно скорее, если они хотят начать использовать технологию OLE в своих приложениях.

procedure TForm1.HTTP1DocOutput(Sender: TObject; const DocOutput: Variant);
var
S: String;
i: integer;
MsgNo, Header: String;
Parser: TSimpleHTMLParser;
ALine: String;
begin
Statusbar1.Panels[2].Text :=
Format('Байт: %s',[DocOutput.BytesTransferred]);
case DocOutput.State of
icDocBegin:
begin
Memo1.Lines.Clear;
Data := '';
end;
icDocData:
begin
DocOutput.GetData(S, VT_BSTR);
Data := Data + S;
end;
icDocEnd:
begin
{ Теперь удаляем все HTML-тэги и отображаем текст }
Parser := TSimpleHTMLParser.Create(Data);
ALine := '';
while Parser.FToken <> etEnd do
begin
case Parser.FToken of
etHTMLTag:
begin
if Parser.TokenHTMLTagIs('BR') then
ALine := ALine + #13#10;
if Parser.TokenHTMLTagIs('P') then
ALine := ALine + #13#10#13#10;
end;
etSymbol: ALine := ALine + ' ' + Parser.FTokenString;
etLineEnd:
begin
Memo1.Lines.Add(ALine);
ALine := '';
end;
end;
Parser.NextToken;
end;
Memo1.Lines.Add(ALine);
Memo1.SelStart := 0;
SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
end;
end;
Refresh;
end;

[001073]


Захват текущего URL у MSIE

The_Sprite советует:

Пример показывает, как найти окно Internet Explorer, и захватить из него текущий URL, находящийся в поле адреса IE. В Исходнике используются простые функции win32 api на delphi.

{-------------------------------------------------------}
Function GetText(WindowHandle: hwnd):string;
var
txtLength : integer;
buffer: string;
begin
TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
txtlength := txtlength + 1;
setlength (buffer, txtlength);
sendmessage (WindowHandle,wm_gettext, txtlength, longint(@buffer[1]));
result := buffer;
end;

function GetURL:string;
var
ie,toolbar,combo,
comboboxex,edit,
worker,toolbarwindow:hwnd;
begin
ie := FindWindow(pchar('IEFrame'),nil);
worker := FindWindowEx(ie,0,'WorkerA',nil);
toolbar := FindWindowEx(worker,0,'rebarwindow32',nil);
comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
combo := FindWindowEx(comboboxex,0,'ComboBox',nil);
edit := FindWindowEx(combo,0,'Edit',nil);
toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);

result := GetText(edit);
{-------------------------------------------------------}

procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(GetURL);
end;

[001381]


Delphi 2

Заставьте приложение Delphi 2 `петь`

Тема: Как заставить приложение Delphi 2 `петь`.

(* Данный совет демонстрирует четыре различных способа как заставить ваше Delphi 2.0 приложение `петь`, т.е. загружать и проигрывать звуковой файл:

  1. Для проигрывания звукового файла используйте непосредственно функцию sndPlaySound().
  2. Считывайте звуковой файл в память, затем для его проигрывания используйте sndPlaySound()
  3. Используйте sndPlaySound для непосредственного проигрывания звуковых файлов, расположенных в файлах ресурсов, прилинкованных к вашему приложению.
  4. Считывайте звуковой файл, располагаемый в файле ресурса, прилинкованному к вашему приложению, в память, и затем для его проигрывания используйте sndPlaySound().
Для построения проекта вам понадобиться:
  1. Создайте звуковой файл с именем 'hello.wav' в каталоге проекта.
  2. Создайте текстовый файл с именем 'snddata.rc' в каталоге проекта.
  3. Добавьте следующую строку к файлу 'snddata.rc': HELLO WAVE hello.wav
  4. В dos-сессии перейдите в ваш каталог приложения и скомпилируйте .rc-файл, используя компилятор ресурсов Borland (brcc32.exe): введите путь к brcc32.exe и передайте 'snddata.rc' в качестве параметра.
Пример:

bin\brcc32 snddata.rc

Это создаст файл 'snddata.res', который Delphi слинкует с EXE-файлом вашего приложения.

Далее приведен необходимый вам код:

unit PlaySnd1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
PlaySndFromFile: TButton;
PlaySndFromMemory: TButton;
PlaySndbyLoadRes: TButton;
PlaySndFromRes: TButton;
procedure PlaySndFromFileClick(Sender: TObject);
procedure PlaySndFromMemoryClick(Sender: TObject);
procedure PlaySndFromResClick(Sender: TObject);
procedure PlaySndbyLoadResClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{$R snddata.res}
uses MMSystem;

procedure TForm1.PlaySndFromFileClick(Sender: TObject);
begin
sndPlaySound('hello.wav', SND_FILENAME or SND_SYNC);
end;

procedure TForm1.PlaySndFromMemoryClick(Sender: TObject);
var
f: file;
p: pointer;
fs: integer;
begin
AssignFile(f, 'hello.wav');
Reset(f,1);
fs := FileSize(f);
GetMem(p, fs);
BlockRead(f, p^, fs);
CloseFile(f);
sndPlaySound(p, SND_MEMORY or SND_SYNC);
FreeMem(p, fs);
end;

procedure TForm1.PlaySndFromResClick(Sender: TObject);
begin
PlaySound('HELLO', hInstance, SND_RESOURCE or SND_SYNC);
end;

procedure TForm1.PlaySndbyLoadResClick(Sender: TObject);
var
h: THandle;
p: pointer;
begin
h := FindResource(hInstance, 'HELLO', 'WAVE');
h := LoadResource(hInstance, h);
p := LockResource(h);
sndPlaySound(p, SND_MEMORY or SND_SYNC);
UnLockResource(h);
FreeResource(h);
end;

end.

[001026]


Создание нового WAV-файла

Тема: Создание нового файла с расширением .wav.

Данный документ был создан по многочисленным просьбам пользователей и описывает дополнительную функциональность компонента Delphi TMediaPlayer. Новая функциональность компонента заключается в возможности создания при записи нового файла формата .wav. Процедура "SaveMedia" создает тип record, передаваемый команде MCISend. Существует исключение, которое вызывает закрытие медиа при любой ошибке, возникающей при открытии определенного файла. Приложение состоит из двух кнопок. Button1 вызывает по-порядку процедуры OpenMedia и RecordMedia. Процедура CloseMedia вызывается при генерации приложением исключительной ситуации. Button2 вызывает процедуры StopMedia,SaveMedia и CloseMedia.

unit utestrec;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs,MPlayer,MMSystem,StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure AppException(Sender: TObject; E: Exception);
private
FDeviceID: Word;
{ Private declarations }
public
procedure OpenMedia;
procedure RecordMedia;
procedure StopMedia;
procedure SaveMedia;
procedure CloseMedia;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
MyError,Flags: Longint;

procedure TForm1.OpenMedia;
var
MyOpenParms: TMCI_Open_Parms;
MyPChar: PChar;
TextLen: Longint;
begin
Flags:=mci_Wait or mci_Open_Element or mci_Open_Type;
with MyOpenParms do
begin
dwCallback:=Handle; // TForm1.Handle
lpstrDeviceType:=PChar('WaveAudio');
lpstrElementName:=PChar('');
end;
MyError:=mciSendCommand(0, mci_Open, Flags,
Longint(@MyOpenParms));
if MyError = 0 then
FDeviceID:=MyOpenParms.wDeviceID;
end;

procedure TForm1.RecordMedia;
var
MyRecordParms: TMCI_Record_Parms;
TextLen: Longint;
begin
Flags:=mci_Notify;
with MyRecordParms do
begin
dwCallback:=Handle;  // TForm1.Handle
dwFrom:=0;
dwTo:=10000;
end;
MyError:=mciSendCommand(FDeviceID, mci_Record, Flags,
Longint(@MyRecordParms));
end;

procedure TForm1.StopMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then
begin
Flags:=mci_Wait;
MyGenParms.dwCallback:=Handle;  // TForm1.Handle
MyError:=mciSendCommand(FDeviceID, mci_Stop, Flags,
Longint(@MyGenParms));
end;
end;

procedure TForm1.SaveMedia;
type    // не реализовано в Delphi
PMCI_Save_Parms = ^TMCI_Save_Parms;
TMCI_Save_Parms = record
dwCallback: DWord;
lpstrFileName: PAnsiChar;  // имя файла, который нужно сохранить
end;
var
MySaveParms: TMCI_Save_Parms;
begin
if FDeviceID <> 0 then
begin
// сохраняем файл...
Flags:=mci_Save_File or mci_Wait;
with MySaveParms do
begin
dwCallback:=Handle;
lpstrFileName:=PChar('c:\message.wav');
end;
MyError:=mciSendCommand(FDeviceID, mci_Save, Flags,
Longint(@MySaveParms));
end;
end;

procedure TForm1.CloseMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then
begin
Flags:=0;
MyGenParms.dwCallback:=Handle; // TForm1.Handle
MyError:=mciSendCommand(FDeviceID, mci_Close, Flags,
Longint(@MyGenParms));
if MyError = 0 then
FDeviceID:=0;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
OpenMedia;
RecordMedia;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
StopMedia;
SaveMedia;
CloseMedia;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := AppException;
end;

procedure TForm1.AppException(Sender: TObject; E: Exception);
begin
CloseMedia;
end;

end.

[001087]


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

Nomadic советует:

Да всё пpосто. Даже, я бы сказал, тyпо. :-)

INT GetMasterVolumeControlID()
{
  // get dwLineID
  MIXERLINE mxl;
  mxl.cbStruct = sizeof(MIXERLINE);
  mxl.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
  if (::mixerGetLineInfo((HMIXEROBJ)ghmx, &mxl,
    MIXER_OBJECTF_HMIXER | MIXER_GETLINEINFOF_COMPONENTTYPE)
    != MMSYSERR_NOERROR)
    return 34;
  // get dwControlID
  MIXERCONTROL mxc;
  MIXERLINECONTROLS mxlc;
  mxlc.cbStruct = sizeof(MIXERLINECONTROLS);
  mxlc.dwLineID = mxl.dwLineID;
  mxlc.dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME;
  mxlc.cControls = 1;
  mxlc.cbmxctrl = sizeof(MIXERCONTROL);
  mxlc.pamxctrl = &mxc;
  if (::mixerGetLineControls((HMIXEROBJ)ghmx, &mxlc,
    MIXER_OBJECTF_HMIXER | MIXER_GETLINECONTROLSF_ONEBYTYPE)
    != MMSYSERR_NOERROR)
    return 34;
  return mxc.dwControlID;
}

 BOOL SetMasterVolume(DWORD dwVolume)
 {
   MIXERCONTROLDETAILS mxcd;
   MIXERCONTROLDETAILS_UNSIGNED mxcd_u;
   mxcd.cbStruct = sizeof(mxcd);
   mxcd.dwControlID = MasterVolumeControlID;
   mxcd.cChannels = 1;
   mxcd.cMultipleItems = 0;
   mxcd.cbDetails = 4;
   mxcd.paDetails = &mxcd_u;
   mmr = mixerGetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
   if (MMSYSERR_NOERROR != mmr) return FALSE;
   mxcd_u.dwValue = dwVolume;
   mmr = mixerSetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
   if (MMSYSERR_NOERROR != mmr) return FALSE;
   return TRUE;
 }
Переписывать на Delphi, думаю, ни к чему. Надо лишь не забыть добавить uses MMSystem; Громкость отдельных каналов очень просто устанавливается через auxSetVolume и аналогичные. [001088]


Как использовать в своей программе API DirectSound и DirectSound3D?

Nomadic советует:

Пример 1

Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WAV'файла в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).

PS. Если есть какие-нибудь вопросы, постараюсь на них ответить.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
DirectSound          : IDirectSound;
DirectSoundBuffer    : IDirectSoundBuffer;
SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0],22050,8,False,10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1],22050,16,True,1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then DirectSound.Release;
end;

procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1,AudioPtr2     : Pointer;
AudioBytes1,AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST  then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
Raise Exception.Create('Unable to Lock Sound Buffer');
end else
if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK
then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc  : DSBUFFERDESC;
Caps        : DSBCaps;
PCM         : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
end;

procedure TForm1.AppCreateWriteSecondaryBuffer;
var BufferDesc  : DSBUFFERDESC;
Caps        : DSBCaps;
PCM         : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.CopyWAVToBuffer;
var Data  : PChar;
FName    : TFileStream;
DataSize : DWord;
Chunk    : String[4];
Pos      : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);

if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');

if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');
end;

end.

Пример 2

Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1{X},1{Y},0{Z}).

Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :

                  ^ Z
                  |
    А             |
                  |
                  O----------------> X
Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно.

При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется, Вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1.

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

PS. Если есть вопросы, постараюсь на них ответить.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
DirectSound            : IDirectSound;
DirectSoundBuffer      : IDirectSoundBuffer;
SecondarySoundBuffer   : IDirectSoundBuffer;
SecondarySound3DBuffer : IDirectSound3DBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
var _3DBuffer: IDirectSound3DBuffer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var Result : HResult;
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer,22050,8,False,4);
AppSetSecondary3DBuffer(SecondarySoundBuffer,SecondarySound3DBuffer);
Timer1.Enabled:=False;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
if Assigned(SecondarySound3DBuffer) then SecondarySound3DBuffer.Release;
if Assigned(SecondarySoundBuffer) then SecondarySoundBuffer.Release;
if Assigned(DirectSound) then DirectSound.Release;
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc  : DSBUFFERDESC;
Caps        : DSBCaps;
PCM         : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK
then Raise Exception.Create('Unable to set Cooperative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK
then Raise Exception.Create('Unable to set Cooperative Level');
end;

procedure TForm1.AppCreateWriteSecondary3DBuffer;
var BufferDesc  : DSBUFFERDESC;
Caps        : DSBCaps;
PCM         : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.AppWriteDataToBuffer;
var AudioPtr1,AudioPtr2     : Pointer;
AudioBytes1,AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST  then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
Raise Exception.Create('Unable to Lock Sound Buffer');
end else
if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK
then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.CopyWAVToBuffer;
var Data     : PChar;
FName    : TFileStream;
DataSize : DWord;
Chunk    : String[4];
Pos      : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;

var Pos : Single = -25;

procedure TForm1.AppSetSecondary3DBuffer;
begin
if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound3D object');
if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
Raise Exception.Create('Failed to set IDirectSound3D Position');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);

if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK
then ShowMessage('Can''t play the Sound');

Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
Pos:=Pos + 0.1;
end;

end.

[001096]


Как получить серийный номер AudioCD?

Олег Кулабухов приводит следующий код:

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId,
MCI_INFO,
MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;

end.

[001840]


Открытие и закрытие нескольких приводов CD-ROM

Что касается вопроса "Открытие и закрытие привода CD-ROM", то при наличии более одного CD-ROMа в системе, рекомендую воспользоваться следующими функциями:

//                  ____       _          ______            __
//                 / __ \_____(_)   _____/_  __/___  ____  / /____
//                / / / / ___/ / | / / _ \/ / / __ \/ __ \/ / ___/
//               / /_/ / /  / /| |/ /  __/ / / /_/ / /_/ / (__  )
//              /_____/_/  /_/ |___/\___/_/  \____/\____/_/____/
//
(*******************************************************************************
* DriveTools 1.0                                                               *
*                                                                              *
*                 (c) 1999 Jan Peter Stotz                                     *
*                                                                              *
********************************************************************************
*                                                                              *
* If you find bugs, has ideas for missing featurs, feel free to contact me     *
*                           jpstotz@gmx.de                                     *
*                                                                              *
********************************************************************************
* Date last modified:   May 22, 1999                                           *
*******************************************************************************)
unit DriveTools;

interface

uses
Windows, SysUtils, MMSystem;

function CloseCD(Drive : Char) : Boolean;
function OpenCD(Drive : Char) : Boolean;

implementation

function OpenCD(Drive : Char) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
IF Res=0 Then exit;Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

function CloseCD(Drive : Char) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

end.

Прислал Vadim Petrov. [001266]


Как получить информацию о загрузке процессора?

Из советов Nomadic'a:

Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage. [001683]


Опыт читателя

Как получить серийный номер тома жесткого диска?

Своим опытом делится Олег Кулабухов:

Вот, посмотрите пример, в нем достается и еще кое-какая полезная информация.

procedure TForm1.Button1Click(Sender: TObject);
var
VolumeName,
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength,
FileSystemFlags : Integer;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags,
FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;

[001860]


Переключение клавиатуры I

Переключение языков из программы

Для переключения языка применяется вызов LoadKeyboardLayout:

var russian, latin: HKL;
russian:=LoadKeyboardLayout('00000419', 0);
latin:=LoadKeyboardLayout('00000409', 0); где то в программе
SetActiveKeyboardLayout(russian);

Прислал Igor Nikolaev aKa The Sprite. [001405]


Переключение клавиатуры II

Здесь переключатели на русский и на английский.

procedure SetRU;
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;

procedure SetEN;
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;

Прислал Nomadic. [001616]


Как отловить нажатия клавиш в системе

Для этого используется функция GetAsyncKeyState(KeyCode)
в качестве параметра используются коды клавиш(например A - 65).
GetAsyncKeyState возвращает не нулевое значение если, во время ее вызова нажата указаная клавиша.

//----Этот пример отлавливает нажатие клавиши "A"
//Этот код необходимо поместить в процедуру обработки
//таймера с интервалом "1"
 if getasynckeystate(65)<>0 then showmessage('A - pressed');
//----------

Прислал Igor Nikolaev aKa The Sprite.

Nomadic дополняет, что функция GetAsyncKeyState годится как для клавиатуpы, так и для мыши. [001407]


Delphi 1

Клавиша с кодом #0

В действительности она служит флагом проверки нажатия клавиши, по соглашению, код #0 означает, что никакой клавиши нажато не было. В некоторых случаях событие может активизировать передачу этого кода (например, прямым вызовом), или предок, возможно, уже обработал нажатие клавиши, и Key был установлен в #0. [001446]


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

Как из программы переключить раскладку клавиатуры?

Nomadic отвечает:

A: ActivateKeyboardLayout(). Учтите, что использование этой функции -- плохой тон. [001545]


Каким образом можно спрятать приложение от показа при нажатии Alt+Tab?

Пример (работает только в Win'95):

var  WnHnd   : Integer;
........................................................
WnHnd := GetWindowLong(Application.Handle, GWL_EXSTYLE);
WnHnd := WnHnd or WS_EX_TOOLWINDOW;
SetWindowLong(Application.Handle, GWL_EXSTYLE, WnHnd);
........................................................

Прислал Nomadic. [001642]


Подскажите пожалуйста как сделать имитацию ввода с клавиатуры для программы выполняющейся в дос-окне?

Nomadic дает следующий пример:

const
ExtendedKeys: set of Byte = [  // incomplete list
VK_INSERT, VK_DELETE, VK_HOME,   VK_END,    VK_PRIOR,   VK_NEXT,
VK_LEFT,   VK_UP,     VK_RIGHT,  VK_DOWN,   VK_NUMLOCK
];

procedure SimulateKeyDown(Key : byte);
var
flags: DWORD;
begin
if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0;
keybd_event(Key, MapVirtualKey(Key, 0), flags, 0);
end;

procedure SimulateKeyUp(Key : byte);
var
flags: DWORD;
begin
if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0;
keybd_event(Key, MapVirtualKey(Key, 0), KEYEVENTF_KEYUP or flags, 0);
end;

procedure SimulateKeystroke(Key : byte);
var
flags: DWORD;
scancode: BYTE;
begin
if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0;
scancode := MapVirtualKey(Key, 0);
keybd_event(Key,
scancode,
flags,
0);
keybd_event(Key,
scancode,
KEYEVENTF_KEYUP or flags,
0);
end;

[001694]


Как включать/выключать лампочки на numlock, capslock, etc...?

Nomadic дает следующий пример:

procedure SetNumLock(bState:Boolean);
var
KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if ( (bState) and (not ((KeyState[VK_NUMLOCK] and 1)=1) ) or
( (not (bState)) and ((KeyState[VK_NUMLOCK] and 1)=1))) then
// Simulate a key press
keybd_event(VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or 0), 0);
// Simulate a key release
keybd_event( VK_NUMLOCK, $45,  (KEYEVENTF_EXTENDEDKEY or
KEYEVENTF_KEYUP), 0);
end;

Заменяйте VK_NUMLOCK на все что душе угодно. [001704]


Тpебyется чтобы пpи нажатии =Enter= в любом из нескольких Edit-ов на фоpме, фокyс пеpеходил в следyющий

Nomadic дает следующий пример:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If Key=#13 Then
Begin
Key:=#0;
SelectNext(Sender as TWinControl, true, true);
{ или Perform(WM_NEXTDLGCTL, 0, 0);  }
End;
end;

А кстати как у тебя с Tab order ... список правильно выстроен... [001714]


Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC

Nomadic поясняет:

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

// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);

Кстати, SystemParametersInfo имеет еще кучу полезных ключей SPI_****, подробности см. в win32.hlp [001753]


Включение/выключение клавиатуры

Alexander V. Timoshenko делится своими секретами:

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

// используемые переменные
var
Dummy     : integer=0;
OldKbHook : HHook=0;

impementation

function KbHook( code: Integer; wparam: Word; lparam: LongInt ): LongInt; stdcall;
begin
if code<0 then Result:=CallNextHookEx( oldKbHook, code, wparam, lparam )
else Result:=1;
end;

// включение клавы
procedure TForm1.KeyBoardOn(Sender: TObject);
begin
if OldKbHook <> 0 then begin
UnHookWindowshookEx( OldKbHook );
OldKbHook := 0;
end;
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 0, 0, 0);
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 0, 0, 0);
end;

// выключение клавы
procedure TForm1.KeyBoardOff(Sender: TObject);
begin
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
OldKbHook := SetWindowsHookEx( WH_KEYBOARD, @KbHook, HInstance, 0 );
end;

Некоторые замечания по поводу этих процедур:

  • Если программу упаковать UPX-ом - клава не будет отключаться (причин не знаю).
  • В ДОС-окне клава будет работать (FAR, VC и т.п.) :(
  • Состояния клавиш NumLock,CapsLock,ScrollLock не отслеживаются и могут быть изменены.
  • Возможно EnableHardwareKeyboard более эффективен и прост, но я тоже, к сожалению, не знаю, как им пользоваться.
  • Если вместо WH_KEYBOARD поставить WH_MOUSE, то можно выключать таким образом мышь :-)
[001760]


Как убрать мою программу из списка Alt+Ctrl+Del?

Nomadic делится своими секретами:

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin //Hide
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin //Show
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 0);
end;

[001770]


Delphi 1

Перехват формой нажатия клавиши ESC

  1. Проверьте в обработчике события TEdit OnKeyPress наличие кода клавиши #27
  2. если код не перехватывается, установите свойство формы KeyPreview
(убедитесь, что свойство имеет значение true, восстановить его в исходное состояние можно, задав его значение, равное false), и затем в обработчике события формы OnKeyPress проверяйте если Key = #27.

Если и это потерпит неудачу, то для проверки того, какой код нажатой клавиши передается вашему приложению, можно воспользоваться системой сообщений windows. Я делал такие трюки в паре моих приложений, и это совсем не трудно. Если вам это интересно, я сделаю пример. [001772]


Письмо читателя

Как определить нажатие PrintScreen?

Своим опытом делится Олег Кулабухов:

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure AppIdle(Sender: TObject; var Done: Boolean);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.OnIdle := AppIdle;

end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);

begin

if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then

Form1.Caption := 'SnapShot';

Done := True;

end;

[001816]


Письмо читателя

Как определить нажаты ли Shift, Control, Alt в определенный момент?

Своим опытом делится Олег Кулабухов:

function CtrlDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Control] And 128) <> 0);
end;

function ShiftDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Shift] and 128) <> 0);
end;

function AltDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Menu] and 128) <> 0);
end;

procedure TForm1.MenuItem12Click(Sender: TObject);
begin
if ShiftDown then
Form1.Caption := 'Shift' else
Form1.Caption := '';
end;

[001822]


Письмо читателя

Можно ли запретить Alt-F4, чтобы предотвратить закрытие формы?

Своим опытом делится Олег Кулабухов:

procedure TForm1.FormCreate(Sender: TObject);
begin
KeyPreview := true;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if ((ssAlt in Shift) and (Key = VK_F4)) then
Key := 0;
end;

[001834]


Как получить список установленных модемов в Win95/98?

Nomadic советует:

unit PortInfo;

interface

uses Windows, SysUtils, Classes, Registry;

function EnumModems : TStrings;

implementation

function EnumModems : TStrings;

var
R : TRegistry;
s : ShortString;
N : TStringList;
i : integer;
j : integer;
begin
Result:= TStringList.Create;
R:= TRegistry.Create;
try
with R do begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
if HasSubKeys then
begin
N:= TStringList.Create;
try
GetKeyNames(N);
for i:=0 to N.Count - 1 do begin
closekey; { + }
openkey('\System\CurrentControlSet\Services\Class\Modem',false); { + }
OpenKey(N[i], False);
s:= ReadString('AttachedTo');
for j:=1 to 4 do
if Pos(Chr(j+Ord('0')), s) > 0 then
Break;
Result.AddObject(ReadString('DriverDesc'),TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;

end.

[001102]


Как набрать номер модемом?

Олег Кулабухов приводит следующий код:

var
hCommFile : THandle;

procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;

{Dial the phone}
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;

[001838]


Как использовать TAPI для набора телефона, чтобы поговорить голосом?

Олег Кулабухов приводит следующий код:

{tapi Errors}
const TAPIERR_CONNECTED = 0;
const TAPIERR_DROPPED = -1;
const TAPIERR_NOREQUESTRECIPIENT = -2;
const TAPIERR_REQUESTQUEUEFULL = -3;
const TAPIERR_INVALDESTADDRESS = -4;
const TAPIERR_INVALWINDOWHANDLE = -5;
const TAPIERR_INVALDEVICECLASS = -6;
const TAPIERR_INVALDEVICEID = -7;
const TAPIERR_DEVICECLASSUNAVAIL = -8;
const TAPIERR_DEVICEIDUNAVAIL = -9;
const TAPIERR_DEVICEINUSE = -10;
const TAPIERR_DESTBUSY = -11;
const TAPIERR_DESTNOANSWER = -12;
const TAPIERR_DESTUNAVAIL = -13;
const TAPIERR_UNKNOWNWINHANDLE = -14;
const TAPIERR_UNKNOWNREQUESTID = -15;
const TAPIERR_REQUESTFAILED = -16;
const TAPIERR_REQUESTCANCELLED = -17;
const TAPIERR_INVALPOINTER = -18;

{tapi size constants}
const TAPIMAXDESTADDRESSSIZE = 80;
const TAPIMAXAPPNAMESIZE = 40;
const TAPIMAXCALLEDPARTYSIZE = 40;
const TAPIMAXCOMMENTSIZE = 80;
const TAPIMAXDEVICECLASSSIZE = 40;
const TAPIMAXDEVICEIDSIZE = 40;

function tapiRequestMakeCallA(DestAddress : PAnsiChar;
AppName : PAnsiChar;
CalledParty : PAnsiChar;
Comment : PAnsiChar) : LongInt;
stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCallW(DestAddress : PWideChar;
AppName : PWideChar;
CalledParty : PWideChar;
Comment : PWideChar) : LongInt;
stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCall(DestAddress : PChar;
AppName : PChar;
CalledParty : PChar;
Comment : PChar) : LongInt;
stdcall; external 'TAPI32.DLL';

procedure TForm1.Button1Click(Sender: TObject);
var
DestAddress : string;
CalledParty : string;
Comment : string;
begin
DestAddress := '1-555-555-1212';
CalledParty := 'Frank Borland';
Comment := 'Calling Frank';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));

end;

end.

[001839]


Письмо читателя

Управление MouseOver через Hint

Nomadic советует:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
mouse_event(MOUSEEVENTF_MOVE, Random(21) - 10,
Random(21) - 10, 0, 0);
end;

[001745]


Письмо читателя

Поменять кнопки мышки местами

Nomadic советует:

Begin
//---------
 SwapMouseButton(true);  // Поменять обратно - SwapMouseButton(false);
//---------
end;

[001764]


Письмо читателя

Изменение положения курсора мыши

Nomadic советует:

  • Установка курсора мыши в определенное место

    Чтобы установить курсор мыши в какое-либо место экрана необходимо воспользоваться функцией SetCursorPos(x,y); Например: Чтобы установить курсор в верхний левый угол монитора нужно написать следующий код: SetCursorPos(0,0);

  • Получение координат курсора

    Для начала необходимо определить переменную pos типа TPoint.

    Сначала:

    //Вне процедуры!
     Type Tpoint = record
    x:integer;
    y:integer;
    end;

    Потом объявляете саму переменную :

    Var
    Pos: TPoint;

    И собcтвенно получение координат:

    begin;
    GetCursorPos(pos);
    x:=pos.x;
    y:=pos.y;
    end;

    [001768]


Delphi 1

Ассинхронная связь

unit Comm;

interface
uses Messages,WinTypes,WinProcs,Classes,Forms;

type
TPort=(tptNone,tptOne,tptTwo,tptThree,tptFour,tptFive,tptSix,tptSeven,
tptEight);
TBaudRate=(tbr110,tbr300,tbr600,tbr1200,tbr2400,tbr4800,tbr9600,tbr14400,
tbr19200,tbr38400,tbr56000,tbr128000,tbr256000);
TParity=(tpNone,tpOdd,tpEven,tpMark,tpSpace);
TDataBits=(tdbFour,tdbFive,tdbSix,tdbSeven,tdbEight);
TStopBits=(tsbOne,tsbOnePointFive,tsbTwo);
TCommEvent=(tceBreak,tceCts,tceCtss,tceDsr,tceErr,tcePErr,tceRing,tceRlsd,
tceRlsds,tceRxChar,tceRxFlag,tceTxEmpty);
TCommEvents=set of TCommEvent;

const
PortDefault=tptNone;
BaudRateDefault=tbr9600;
ParityDefault=tpNone;
DataBitsDefault=tdbEight;
StopBitsDefault=tsbOne;
ReadBufferSizeDefault=2048;
WriteBufferSizeDefault=2048;
RxFullDefault=1024;
TxLowDefault=1024;
EventsDefault=[];

type
TNotifyEventEvent=procedure(Sender:TObject;CommEvent:TCommEvents) of object;
TNotifyReceiveEvent=procedure(Sender:TObject;Count:Word) of object;
TNotifyTransmitEvent=procedure(Sender:TObject;Count:Word) of object;

TComm=class(TComponent)
private
FPort:TPort;
FBaudRate:TBaudRate;
FParity:TParity;
FDataBits:TDataBits;
FStopBits:TStopBits;
FReadBufferSize:Word;
FWriteBufferSize:Word;
FRxFull:Word;
FTxLow:Word;
FEvents:TCommEvents;
FOnEvent:TNotifyEventEvent;
FOnReceive:TNotifyReceiveEvent;
FOnTransmit:TNotifyTransmitEvent;
FWindowHandle:hWnd;
hComm:Integer;
HasBeenLoaded:Boolean;
Error:Boolean;
procedure SetPort(Value:TPort);
procedure SetBaudRate(Value:TBaudRate);
procedure SetParity(Value:TParity);
procedure SetDataBits(Value:TDataBits);
procedure SetStopBits(Value:TStopBits);
procedure SetReadBufferSize(Value:Word);
procedure SetWriteBufferSize(Value:Word);
procedure SetRxFull(Value:Word);
procedure SetTxLow(Value:Word);
procedure SetEvents(Value:TCommEvents);
procedure WndProc(var Msg:TMessage);
procedure DoEvent;
procedure DoReceive;
procedure DoTransmit;
protected
procedure Loaded;override;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure Write(Data:PChar;Len:Word);
procedure Read(Data:PChar;Len:Word);
function IsError:Boolean;
published
property Port:TPort read FPort write SetPort default PortDefault;
property BaudRate:TBaudRate read FBaudRate write SetBaudRate
default BaudRateDefault;
property Parity:TParity read FParity write SetParity default ParityDefault;
property DataBits:TDataBits read FDataBits write SetDataBits
default DataBitsDefault;
property StopBits:TStopBits read FStopBits write SetStopBits
default StopBitsDefault;
property WriteBufferSize:Word read FWriteBufferSize
write SetWriteBufferSize default WriteBufferSizeDefault;
property ReadBufferSize:Word read FReadBufferSize
write SetReadBufferSize default ReadBufferSizeDefault;
property RxFullCount:Word read FRxFull write SetRxFull
default RxFullDefault;
property TxLowCount:Word read FTxLow write SetTxLow default TxLowDefault;
property Events:TCommEvents read FEvents write SetEvents
default EventsDefault;
property OnEvent:TNotifyEventEvent read FOnEvent write FOnEvent;
property OnReceive:TNotifyReceiveEvent read FOnReceive write FOnReceive;
property OnTransmit:TNotifyTransmitEvent read FOnTransmit write FOnTransmit;
end;

procedure Register;

implementation

procedure TComm.SetPort(Value:TPort);
const
CommStr:PChar='COM1:';
begin
FPort:=Value;
if (csDesigning in ComponentState) or
(Value=tptNone) or (not HasBeenLoaded) then exit;
if hComm>=0 then CloseComm(hComm);
CommStr[3]:=chr(48+ord(Value));
hComm:=OpenComm(CommStr,ReadBufferSize,WriteBufferSize);
if hComm<0 then
begin
Error:=True;
exit;
end;
SetBaudRate(FBaudRate);
SetParity(FParity);
SetDataBits(FDataBits);
SetStopBits(FStopBits);
SetEvents(FEvents);
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;

procedure TComm.SetBaudRate(Value:TBaudRate);
var
DCB:TDCB;
begin
FBaudRate:=Value;
if hComm>=0 then
begin
GetCommState(hComm,DCB);
case Value of
tbr110:DCB.BaudRate:=CBR_110;
tbr300:DCB.BaudRate:=CBR_300;
tbr600:DCB.BaudRate:=CBR_600;
tbr1200:DCB.BaudRate:=CBR_1200;
tbr2400:DCB.BaudRate:=CBR_2400;
tbr4800:DCB.BaudRate:=CBR_4800;
tbr9600:DCB.BaudRate:=CBR_9600;
tbr14400:DCB.BaudRate:=CBR_14400;
tbr19200:DCB.BaudRate:=CBR_19200;
tbr38400:DCB.BaudRate:=CBR_38400;
tbr56000:DCB.BaudRate:=CBR_56000;
tbr128000:DCB.BaudRate:=CBR_128000;
tbr256000:DCB.BaudRate:=CBR_256000;
end;
SetCommState(DCB);
end;
end;

procedure TComm.SetParity(Value:TParity);
var
DCB:TDCB;
begin
FParity:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tpNone:DCB.Parity:=0;
tpOdd:DCB.Parity:=1;
tpEven:DCB.Parity:=2;
tpMark:DCB.Parity:=3;
tpSpace:DCB.Parity:=4;
end;
SetCommState(DCB);
end;

procedure TComm.SetDataBits(Value:TDataBits);
var
DCB:TDCB;
begin
FDataBits:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tdbFour:DCB.ByteSize:=4;
tdbFive:DCB.ByteSize:=5;
tdbSix:DCB.ByteSize:=6;
tdbSeven:DCB.ByteSize:=7;
tdbEight:DCB.ByteSize:=8;
end;
SetCommState(DCB);
end;

procedure TComm.SetStopBits(Value:TStopBits);
var
DCB:TDCB;
begin
FStopBits:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tsbOne:DCB.StopBits:=0;
tsbOnePointFive:DCB.StopBits:=1;
tsbTwo:DCB.StopBits:=2;
end;
SetCommState(DCB);
end;

procedure TComm.SetReadBufferSize(Value:Word);
begin
FReadBufferSize:=Value;
SetPort(FPort);
end;

procedure TComm.SetWriteBufferSize(Value:Word);
begin
FWriteBufferSize:=Value;
SetPort(FPort);
end;

procedure TComm.SetRxFull(Value:Word);
begin
FRxFull:=Value;
if hComm<0 then exit;
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;

procedure TComm.SetTxLow(Value:Word);
begin
FTxLow:=Value;
if hComm<0 then exit;
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;

procedure TComm.SetEvents(Value:TCommEvents);
var
EventMask:Word;
begin
FEvents:=Value;
if hComm<0 then exit;
EventMask:=0;
if tceBreak in FEvents then inc(EventMask,EV_BREAK);
if tceCts in FEvents then inc(EventMask,EV_CTS);
if tceCtss in FEvents then inc(EventMask,EV_CTSS);
if tceDsr in FEvents then inc(EventMask,EV_DSR);
if tceErr in FEvents then inc(EventMask,EV_ERR);
if tcePErr in FEvents then inc(EventMask,EV_PERR);
if tceRing in FEvents then inc(EventMask,EV_RING);
if tceRlsd in FEvents then inc(EventMask,EV_RLSD);
if tceRlsds in FEvents then inc(EventMask,EV_RLSDS);
if tceRxChar in FEvents then inc(EventMask,EV_RXCHAR);
if tceRxFlag in FEvents then inc(EventMask,EV_RXFLAG);
if tceTxEmpty in FEvents then inc(EventMask,EV_TXEMPTY);
SetCommEventMask(hComm,EventMask);
end;

procedure TComm.WndProc(var Msg:TMessage);
begin
with Msg do
begin
if Msg=WM_COMMNOTIFY then
begin
case lParamLo of
CN_EVENT:DoEvent;
CN_RECEIVE:DoReceive;
CN_TRANSMIT:DoTransmit;
end;
end
else
Result:=DefWindowProc(FWindowHandle,Msg,wParam,lParam);
end;
end;

procedure TComm.DoEvent;
var
CommEvent:TCommEvents;
EventMask:Word;
begin
if (hComm<0) or not Assigned(FOnEvent) then exit;
EventMask:=GetCommEventMask(hComm,Integer($FFFF));
CommEvent:=[];
if (tceBreak in Events) and (EventMask and EV_BREAK<>0) then
CommEvent:=CommEvent+[tceBreak];
if (tceCts in Events) and (EventMask and EV_CTS<>0) then
CommEvent:=CommEvent+[tceCts];
if (tceCtss in Events) and (EventMask and EV_CTSS<>0) then
CommEvent:=CommEvent+[tceCtss];
if (tceDsr in Events) and (EventMask and EV_DSR<>0) then
CommEvent:=CommEvent+[tceDsr];
if (tceErr in Events) and (EventMask and EV_ERR<>0) then
CommEvent:=CommEvent+[tceErr];
if (tcePErr in Events) and (EventMask and EV_PERR<>0) then
CommEvent:=CommEvent+[tcePErr];
if (tceRing in Events) and (EventMask and EV_RING<>0) then
CommEvent:=CommEvent+[tceRing];
if (tceRlsd in Events) and (EventMask and EV_RLSD<>0) then
CommEvent:=CommEvent+[tceRlsd];
if (tceRlsds in Events) and (EventMask and EV_Rlsds<>0) then
CommEvent:=CommEvent+[tceRlsds];
if (tceRxChar in Events) and (EventMask and EV_RXCHAR<>0) then
CommEvent:=CommEvent+[tceRxChar];
if (tceRxFlag in Events) and (EventMask and EV_RXFLAG<>0) then
CommEvent:=CommEvent+[tceRxFlag];
if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY<>0) then
CommEvent:=CommEvent+[tceTxEmpty];
FOnEvent(Self,CommEvent);
end;

procedure TComm.DoReceive;
var
Stat:TComStat;
begin
if (hComm<0) or not Assigned(FOnReceive) then exit;
GetCommError(hComm,Stat);
FOnReceive(Self,Stat.cbInQue);
GetCommError(hComm,Stat);
end;

procedure TComm.DoTransmit;
var
Stat:TComStat;
begin
if (hComm<0) or not Assigned(FOnTransmit) then exit;
GetCommError(hComm,Stat);
FOnTransmit(Self,Stat.cbOutQue);
end;

procedure TComm.Loaded;
begin
inherited Loaded;
HasBeenLoaded:=True;
SetPort(FPort);
end;

constructor TComm.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FWindowHandle:=AllocateHWnd(WndProc);
HasBeenLoaded:=False;
Error:=False;
FPort:=PortDefault;
FBaudRate:=BaudRateDefault;
FParity:=ParityDefault;
FDataBits:=DataBitsDefault;
FStopBits:=StopBitsDefault;
FWriteBufferSize:=WriteBufferSizeDefault;
FReadBufferSize:=ReadBufferSizeDefault;
FRxFull:=RxFullDefault;
FTxLow:=TxLowDefault;
FEvents:=EventsDefault;
hComm:=-1;
end;

destructor TComm.Destroy;
begin
DeallocatehWnd(FWindowHandle);
if hComm>=0 then CloseComm(hComm);
inherited Destroy;
end;

procedure TComm.Write(Data:PChar;Len:Word);
begin
if hComm<0 then exit;
if WriteComm(hComm,Data,Len)<0 then Error:=True;
GetCommEventMask(hComm,Integer($FFFF));
end;

procedure TComm.Read(Data:PChar;Len:Word);
begin
if hComm<0 then exit;
if ReadComm(hComm,Data,Len)<0 then Error:=True;
GetCommEventMask(hComm,Integer($FFFF));
end;

function TComm.IsError:Boolean;
begin
IsError:=Error;
Error:=False;
end;

procedure Register;
begin
RegisterComponents('Additional',[TComm]);
end;

end.

[001161]


Delphi 2

Печать табуляторов с помощью TextOut

Я пытаюсь напечатать некий текст с помощью Printer.Canvas.TextOut. Моя строка содержит табуляторы, но они почему-то печатаются на бумаге в виде черных прямоугольников. Как мне правильно напечатать строку, содержащую табуляторы?

Обратите внимание на функцию API "TabbedTextOut". Ваш холст (canvas) воспользоваться ей не сможет, но вы можете просто вызвать эту API функцию и передать ей дескриптор холста.

- Bob Fisher [001059]


Печать через спулер на матричный принтер

Оргиш Александр (FIDO: 2:454/3.24) пишет:

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

Var pcbNeeded : DWORD;
FDevice : PChar;
FPort   : PChar;
FDriver : PChar;
FPrinterHandle : THandle;
FDeviceMode    : THandle;
FJob           : PADDJOBINFO1 ;
Stream         : TFileStream;
begin
GetMem(FDevice, 128);
GetMem(FDriver, 128);
GetMem(FPort, 128);
Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if FDeviceMode = 0
then Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if OpenPrinter(FDevice,FPrinterHandle,nil) then  begin
GetMem(FJob,1024);
//Добавляем задание, получаем имя файла в директории windows\spoool\
AddJob(FPrinterHandle,1,FJob,1024,pcbNeeded);
Stream:=TFileStream.Create(FJob.Path,fmCreate);
// Дальше пишем текст (+ESC команды!!!!) прямо в Stream
// и не забываем переводить в DOS - кодировку
.........
.........
Stream.Free;
//Постановка задания в очередь - только теперь принтер начинает печатать
ScheduleJob(FPrinterHandle,FJob.JobID);
FreeMem(FJob);
ClosePrinter(FPrinterHandle);
end;
FreeMem(FDevice, 128);
FreeMem(FDriver, 128);
FreeMem(FPort, 128);
end;

С уважением, Оргиш Александр [001072]


Лучший способ печати формы

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

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

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

unit Prntit;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
dc: HDC;
isDcPalDevice : BOOL;
MemDc :hdc;
MemBitmap : hBitmap;
OldMemBitmap : hBitmap;
hDibHeader : Thandle;
pDibHeader : pointer;
hBits : Thandle;
pBits : pointer;
ScaleX : Double;
ScaleY : Double;
ppal : PLOGPALETTE;
pal : hPalette;
Oldpal : hPalette;
i : integer;
begin
{Получаем dc экрана}
dc := GetDc(0);
{Создаем совместимый dc}
MemDc := CreateCompatibleDc(dc);
{создаем изображение}
MemBitmap := CreateCompatibleBitmap(Dc,
form1.width,
form1.height);
{выбираем изображение в dc}
OldMemBitmap := SelectObject(MemDc, MemBitmap);

{Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов}
isDcPalDevice := false;
if GetDeviceCaps(dc, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then begin
GetMem(pPal, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
FillChar(pPal^, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
pPal^.palPalEntry);
if pPal^.PalNumEntries <> 0 then begin
pal := CreatePalette(pPal^);
oldPal := SelectPalette(MemDc, Pal, false);
isDcPalDevice := true
end else
FreeMem(pPal, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
end;

{копируем экран в memdc/bitmap}
BitBlt(MemDc,
0, 0,
form1.width, form1.height,
Dc,
form1.left, form1.top,
SrcCopy);

if isDcPalDevice = true then begin
SelectPalette(MemDc, OldPal, false);
DeleteObject(Pal);
end;

{удаляем выбор изображения}
SelectObject(MemDc, OldMemBitmap);
{удаляем dc памяти}
DeleteDc(MemDc);
{Распределяем память для структуры DIB}
hDibHeader := GlobalAlloc(GHND,
sizeof(TBITMAPINFO) +
(sizeof(TRGBQUAD) * 256));
{получаем указатель на распределенную память}
pDibHeader := GlobalLock(hDibHeader);

{заполняем dib-структуру информацией, которая нам необходима в DIB}
FillChar(pDibHeader^,
sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256),
#0);
PBITMAPINFOHEADER(pDibHeader)^.biSize :=
sizeof(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

{узнаем сколько памяти необходимо для битов}
GetDIBits(dc,
MemBitmap,
0,
form1.height,
nil,
TBitmapInfo(pDibHeader^),
DIB_RGB_COLORS);

{Распределяем память для битов}
hBits := GlobalAlloc(GHND,
PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
{Получаем указатель на биты}
pBits := GlobalLock(hBits);

{Вызываем функцию снова, но на этот раз нам передают биты!}
GetDIBits(dc,
MemBitmap,
0,
form1.height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);

{Пробуем исправить ошибки некоторых видеодрайверов}
if isDcPalDevice = true then begin
for i := 0 to (pPal^.PalNumEntries - 1) do begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed :=
pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
end;

{Освобождаем dc экрана}
ReleaseDc(0, dc);
{Удаляем изображение}
DeleteObject(MemBitmap);

{Запускаем работу печати}
Printer.BeginDoc;

{Масштабируем размер печати}
if Printer.PageWidth < Printer.PageHeight then begin
ScaleX := Printer.PageWidth;
ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
end else begin
ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
ScaleY := Printer.PageHeight;
end;

{Просто используем драйвер принтера для устройства палитры}
isDcPalDevice := false;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then begin
{Создаем палитру для dib}
GetMem(pPal, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
FillChar(pPal^, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.PalNumEntries - 1) do begin
pPal^.palPalEntry[i].peRed :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, sizeof(TLOGPALETTE) +
(255 * sizeof(TPALETTEENTRY)));
oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
isDcPalDevice := true
end;

{посылаем биты на принтер}
StretchDiBits(Printer.Canvas.Handle,
0, 0,
Round(scaleX), Round(scaleY),
0, 0,
Form1.Width, Form1.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS,
SRCCOPY);

{Просто используем драйвер принтера для устройства палитры}
if isDcPalDevice = true then begin
SelectPalette(Printer.Canvas.Handle, oldPal, false);
DeleteObject(Pal);
end;

{Очищаем распределенную память}GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);

{Заканчиваем работу печати}
Printer.EndDoc;

end;

[001081]


Как мне отправить на принтер чистый поток данных?

Nomadic советует:

Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее.

Под Win32 Вы можете использовать WritePrinter.

Ниже пример открытия принтера и записи чистого потока данных в принтер.

Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно.

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

uses WinSpool;

procedure WriteRawStringToPrinter(PrinterName:String; S:String);
var
Handle: THandle;
N: DWORD;
DocInfo1: TDocInfo1;
begin
if not OpenPrinter(PChar(PrinterName), Handle, nil) then
begin
ShowMessage('error ' + IntToStr(GetLastError));
Exit;
end;
with DocInfo1 do
begin
pDocName := PChar('test doc');
pOutputFile := nil;
pDataType := 'RAW';
end;
StartDocPrinter(Handle, 1, @DocInfo1);
StartPagePrinter(Handle);
WritePrinter(Handle, PChar(S), Length(S), N);
EndPagePrinter(Handle);
EndDocPrinter(Handle);
ClosePrinter(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WriteRawStringToPrinter('HP', 'Test This');
end;

Посмотри и доделай как тебе надо.

unit TextPrinter;

interface

uses
Windows, Controls, Forms, Dialogs;

type
TTextPrinter = class(TObject)
private
FNumberOfBytesWritten: Integer;
FHandle: THandle;
FPrinterOpen: Boolean;
FErrorString: PChar;
procedure SetErrorString;
public
constructor Create;
procedure Write(const Str: string);
procedure WriteLn(const Str: string);
destructor Destroy; override;
published
property NumberOfBytesWritten: Integer read FNumberOfBytesWritten;
end;

implementation

{TTextPrinter}

constructor TTextPrinter.Create;
begin
FHandle := CreateFile('LPT1', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ
or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if FHandle = INVALID_HANDLE_VALUE then
begin
SetErrorString;
raise Exception.Create(FErrorString);
end
else
 FPrinterOpen := True;
end;

procedure TTextPrinter.SetErrorString;
begin
if FErrorString <> nil then
LocalFree(Integer(FErrorString));
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
nil,
GetLastError(),
LANG_USER_DEFAULT,
@FErrorString,
0,
nil
);
end;

procedure TTextPrinter.Write(const Str: string);
var
OEMStr: PChar;
NumberOfBytesToWrite: Integer;
begin
if not FPrinterOpen then
Exit;
NumberOfBytesToWrite := Length(Str);
OEMStr := PChar(LocalAlloc(LMEM_FIXED, NumberOfBytesToWrite + 1));
try
CharToOem(PChar(Str), OEMStr);
if not WriteFile(FHandle, OEMStr^, NumberOfBytesToWrite,
FNumberOfBytesWritten, nil) then
begin
SetErrorString;
raise Exception.Create(FErrorString);
end;
finally
LocalFree(Integer(OEMStr));
end;
end;

procedure TTextPrinter.WriteLn(const Str: string);
begin
Self.Write(Str);
Self.Write(#10);
end;

destructor TTextPrinter.Destroy;
begin
CloseHandle(FHandle);
if FErrorString <> nil then
LocalFree(Integer(FErrorString));
end;

end.

P.S. В принципе, вместо LPT1 может стоять что угодно, даже сетевой сервер печати (\\server\prn) - все равно печатает. Можно и параметр в конструктор вставить и т.д. [001114]


Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?

Nomadic советует:

Маленькое пpедисловие.

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

В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться качественной печати в двух pежимах : MetaFile, Bitmap.

Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбpасывать на печать.Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед.

Главная головная боль пpи таком методе - пpи отpисовке больших кусков, котоpые занимают весь лист или его большую часть, надо этот метафайл по pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот пpи увеличении линии и шpифты не "поползут".

Итак :

Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом отдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только - пpиделывание свеpху надстpоек для личного использования.

Вся pабота сводится к следующим шагам :

  1. Получить необходимые коэф-ты;
  2. Постpоить метафайл или bmp для последующего вывода на печать;
  3. Hапечатать.
Hиже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета.

kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что пpиходится учитывать.

Решили пункт 1.

procedure SetKoeffMeta; // установить коэф-ты
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /
Screen.PixelsPerInch;
MetaCanvas.Font.Assign( oGrid.Font);
MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
finally
MetaCanvas.Free;
end;
finally
PrevMetafile.Free;
end;
end;

Решаем 2.

...
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;

try
PrevMetaFile := TMetaFile.Create;

PrevMetafile.Width := oWidth;
PrevMetafile.Height := oHeight;

try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );

// здесь должен быть ваш код - с учетом масштабиpования.
// я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
// вызываю лишь для отpисовки целой стpаницы.
 см. PS1.
finally
MetaCanvas.Free;
end;
...
PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.
...
var
iHPage : integer; // высота страницы
begin
with oCanvas do
begin

iHPage := 3000;

// залили область метайфайла белым - для дальнейшей pаботы
Pen.Color := clBlack;
Brush.Color := clWhite;
FillRect( Rect( 0, 0, 2000, iHPage ) );

// установили шpифты - с учетом их дальнейшего масштабиpования
oCanvas.Font.Assign( oGrid.Font);
oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );

...
xEnd := xBegin;
iH := round( RowHeights[ iRow ] * kH );
for iCol := 0 to ColCount - 1 do
begin
x := xEnd;
xEnd := x + round( ColWidths[ iCol ] * kW );
Rectangle( x, yBegin, xEnd, yBegin + iH );
r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );
s := Cells[ iCol, iRow ];

// выписали в полученный квадрат текст
DrawText( oCanvas.Handle, PChar( s ), Length( s ), r, DT_WORDBREAK or DT_CENTER );

Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid, котоpый сделал для многостpаничной печати. Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.

...
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: Longint;
PrintWidth, PrintHeight: Longint;
begin
...

case ImageType of

itMetafile: begin
if Picture.Metafile<>nil then
Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth, aTop+fHeight), Picture.Metafile);
end;

itBitmap:
begin
if Picture.Bitmap<>nil then
begin
with Printer, Canvas do
begin
Bits := Picture.Bitmap.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do
begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
PrintWidth := DIBWidth;
PrintHeight := DIBHeight;
StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
end;
end;

В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp - отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения. Для показа изобpажения достаточно использовать StretchDraw.

После того, как удалось вывести объекты на печать, пpоблему создания PreView pешили как "домашнее задание".

Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт - записываем битовый обpаз чеpез такую пpоцедуpу:

w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.PixelsPerInch);
h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.PixelsPerInch);
PrevBmp.Width:=w;
PrevBmp.Height:=h;
PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);

aPicture.Assign(PrevBmp);

Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи печати - пpиходится bmp печатать именно так, как описано выше. Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но пpи этом - внешне - без каких-либо искажений и пp.

Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не будет уже точно :)

PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные геокаpты, котоpые по качеству не хуже, а может, и лучше, чем выдает Surfer (специалисты поймут). Hа ватмат.

PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло, охpана уже pугается. Hо код - выдpан из pаботающих исходников.

[001160]


Как вместо печати графикой сказать принтеру, чтобы печатал встроенными шрифтами?

Своим опытом делится Олег Кулабухов:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
tm : TTextMetric;
i : integer;
begin
if PrintDialog1.Execute then begin
Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
GetTextMetrics(Printer.Canvas.Handle, tm);
for i := 1 to 10 do begin
Printer.Canvas.TextOut(100,
i * tm.tmHeight +
tm.tmExternalLeading,
'Test');
end;
Printer.EndDoc;
end;
end;

[001821]


Как печатать в Дельфи без Tprinter?

Своим опытом делится Олег Кулабухов:

Пример показывает, как использовать PrintDlg() для того, чтобы дать возможность пользователю выбрать принтер, и напечатать две страницы.

uses CommDlg;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
Pd : TPrintDlg;
DocInfo: TDocInfo;
begin
FillChar(Pd, sizeof(Pd), #0);
Pd.lStructSize := sizeof(Pd);
Pd.hWndOwner := Form1.Handle;
Pd.Flags := PD_RETURNDC;
if PrintDlg(pd) then begin
FillChar(DocInfo, sizeof(DocInfo), #0);
DocInfo.cbSize := SizeOf(DocInfo);
GetMem(DocInfo.lpszDocName, 32);
GetMem(DocInfo.lpszOutput, MAX_PATH);
lStrCpy(DocInfo.lpszDocName, 'My Document');
{Add this line to print to a file }
lStrCpy(DocInfo.lpszOutput, 'C:\Download\Test.doc');
StartDoc(Pd.hDc, DocInfo);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
EndPage(Pd.hDc);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
EndPage(Pd.hDc);
EndDoc(Pd.hDc);
FreeMem(DocInfo.lpszDocName, 32);
FreeMem(DocInfo.lpszOutput, MAX_PATH);
end;
end;

[001823]


Как распечатать картинку?

Своим кодом делится Олег Кулабухов:

uses Printers;

type
PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc; {Handle of where to blt}
x : word; {Bit at x}
y : word; {Blt at y}
Width : word; {Width to stretch}
Height : word; {Height to stretch}
bm : TBitmap); {the TBitmap to Blt}
var
OriginalWidth :LongInt; {width of BM}
dc : hdc; {screen dc}
IsPaletteDevice : bool; {if the device uses palettes}
IsDestPaletteDevice : bool; {if the device uses palettes}
BitmapInfoSize : integer; {sizeof the bitmapinfoheader}
lpBitmapInfo : PBitmapInfo; {the bitmap info header}
hBm : hBitmap; {handle to the bitmap}
hPal : hPalette; {handle to the palette}
OldPal : hPalette; {temp palette}
hBits : THandle; {handle to the DIB bits}
pBits : pointer; {pointer to the DIB bits}
lPPalEntriesArray : PPalEntriesArray; {palette entry array}
NumPalEntries : integer; {number of palette entries}
i : integer; {looping variable}
begin
{If range checking is on - lets turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

{Save the original width of the bitmap}
 OriginalWidth := bm.Width;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);
{Are we a palette device?}
IsPaletteDevice :=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Allocate the BitmapInfo structure}
if IsPaletteDevice then
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
else
BitmapInfoSize := sizeof(TBitmapInfo);
GetMem(lpBitmapInfo, BitmapInfoSize);

{Zero out the BitmapInfo structure}
FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

{Fill in the BitmapInfo structure}
lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
lpBitmapInfo^.bmiHeader.biPlanes := 1;
if IsPaletteDevice then
lpBitmapInfo^.bmiHeader.biBitCount := 8
else
lpBitmapInfo^.bmiHeader.biBitCount := 24;
lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
lpBitmapInfo^.bmiHeader.biSizeImage :=
((lpBitmapInfo^.bmiHeader.biWidth *
longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
lpBitmapInfo^.bmiHeader.biHeight;
lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
if IsPaletteDevice then begin
lpBitmapInfo^.bmiHeader.biClrUsed := 256;
lpBitmapInfo^.bmiHeader.biClrImportant := 256;
end else begin
lpBitmapInfo^.bmiHeader.biClrUsed := 0;
lpBitmapInfo^.bmiHeader.biClrImportant := 0;
end;

{Take ownership of the bitmap handle and palette}
hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);

if IsPaletteDevice then begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
 OldPal := SelectPalette(dc, hPal, TRUE);
{Realize the palette}
RealizePalette(dc);
end;
{Tell GetDiBits to fill in the rest of the bitmap info structure}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
nil,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

{Allocate memory for the Bits}
hBits := GlobalAlloc(GMEM_MOVEABLE,
lpBitmapInfo^.bmiHeader.biSizeImage);
pBits := GlobalLock(hBits);
{Get the bits}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

if IsPaletteDevice then begin
{Lets fix up the color table for buggy video drivers}
GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
{$IFDEF VER100}
NumPalEntries := GetPaletteEntries(hPal,
0,
256,
lPPalEntriesArray^);
{$ELSE}
NumPalEntries := GetSystemPaletteEntries(dc,
0,
256,
lPPalEntriesArray^);
{$ENDIF}
for i := 0 to (NumPalEntries - 1) do begin
lpBitmapInfo^.bmiColors[i].rgbRed :=
lPPalEntriesArray^[i].peRed;
lpBitmapInfo^.bmiColors[i].rgbGreen :=
lPPalEntriesArray^[i].peGreen;
lpBitmapInfo^.bmiColors[i].rgbBlue :=
lPPalEntriesArray^[i].peBlue;
end;
FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
end;

if IsPaletteDevice then begin
{Select the old palette back in}
SelectPalette(dc, OldPal, TRUE);
{Realize the old palette}
 RealizePalette(dc);
end;

{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Is the Dest dc a palette device?}
IsDestPaletteDevice :=
GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

if IsPaletteDevice then begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
 OldPal := SelectPalette(DestDc, hPal, TRUE);
{Realize the palette}
RealizePalette(DestDc);
end;

{Do the blt}
StretchDiBits(DestDc,
x,
y,
Width,
Height,
0,
0,
OriginalWidth,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
lpBitmapInfo^,
DIB_RGB_COLORS,
SrcCopy);

if IsDestPaletteDevice then begin
{Select the old palette back in}
SelectPalette(DestDc, OldPal, TRUE);
{Realize the old palette}
RealizePalette(DestDc);
end;

{De-Allocate the Dib Bits}
GlobalUnLock(hBits);
GlobalFree(hBits);

{De-Allocate the BitmapInfo}
FreeMem(lpBitmapInfo, BitmapInfoSize);

{Set the ownership of the bimap handles back to the bitmap}
bm.Handle := hBm;
bm.Palette := hPal;

{Turn range checking back on if it was on when we started}
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
 end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then begin
Printer.BeginDoc;
BltTBitmapAsDib(Printer.Canvas.Handle,
0,
0,
Image1.Picture.Bitmap.Width,
Image1.Picture.Bitmap.Height,
Image1.Picture.Bitmap);
Printer.EndDoc;
end;
end;

[001826]


Как определить количество заданий на печать?

Своим кодом делится Олег Кулабухов:

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

type
TForm1 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
message WM_SPOOLERSTATUS;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
begin
Lable1.Caption := IntToStr(msg.JobsLeft) +
' Jobs currenly in spooler';
msg.Result := 0;
end;

[001845]


Как умертвить PC Speaker?

Nomadic советует:

Это выключит спикеp:

SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:

SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

[001597]


Звук через PC Speaker

Nomadic публикует следующий код:

procedure TForm1.mybeep(Tone: Word; Delay: Integer);
begin
asm
mov   al,  0b6H
out   43H, al
mov ax,Tone
out 42h,al
ror ax,8
out 42h,al
in    al,  61H
or    al,  03H
out   61H, al
end;
sleep(Delay);
asm
in    al,  61H
and   al,  0fcH
out   61H, al
end;
end;

[001741]


Как в ATX корпусе программно выключить питание под DOS

Serj Kolesnikov рекомендует:
=== Cut ===
    mov ax,5301h
    sub bx,bx
    int 15h
    jc @@finish
    mov ax,530Eh
    sub bx,bx
    mov cx,102h
    int 15h
    jc @@finish
    mov ax,5307h
    mov bx,1
    mov cx,3
    int 15h
@@finish:
    int 20h
=== Cut ===
[001036]


Как в Delphi определить дату BIOS

Nomadic рекомендует:

Определить дату BIOS, равно как тип ПК или поиметь другие данные, находящиеся по фиксированому _физическому_ адресу, в Delphi можно так:

var
BiosDate:array[0..7] of char absolute
$FFFF5;
PCType  :byte absolute $FFFFE;

procedure TForm1.FormCreate(Sender: TObject);
var
S:string;
begin
case PCType of
$FC:  S:='AT';
$FD:  S:='PCjr';
$FE:  S:='XT =8-O';
$FF:  S:='PC';
else  S:='Нестандартный';
end;
Caption:='Дата BIOS: '+BiosDate+'  Тип ПК: '+S;
end;

[001743]


Как заблокировать ввод?

Andrew Pastushenko советует:

Вот недокументированная функция из User32.dll, которая блокирует ввод (мышь, клавиатуру кроме Ctrl+Alt+Del). При нажатии Ctrl+Alt+Del все разблокируется :-(

procedure BlockInput; external 'user32.dll';

Передаем параметры в стек вручную через push, иначе что-то глючит:

1 - заблокировать
0 - разблокировать

procedure Block;
asm
push 1
call BlockInput
 end;

procedure UnBlock;
asm
push 0
call BlockInput
 end;

[001798]


Как удобнее работать с буфером обмена как с последовательностью байт?

Из советов Nomadic'a:

Используя потоки -

unit ClipStrm;

{
This unit is Copyright (c) Alexey Mahotkin 1997-1998
and may be used freely for any purpose. Please mail
your comments to
E-Mail: alexm@hsys.msk.ru
FidoNet: Alexey Mahotkin, 2:5020/433

This unit was developed during incorporating of TP Lex/Yacc
into my project. Please visit ftp://ftp.nf.ru/pub/alexm
or FREQ FILES from 2:5020/433 or mail me to get hacked
version of TP Lex/Yacc which works under Delphi 2.0+.
}

interface uses Classes, Windows;

type
TClipboardStream = class(TStream)
private
FMemory : pointer;
FSize : longint;
FPosition : longint;
FFormat : word;
public
constructor Create(fmt : word);
destructor Destroy; override;

function Read(var Buffer; Count : Longint) : Longint; override;
function Write(const Buffer; Count : Longint) : Longint; override;
function Seek(Offset : Longint; Origin : Word) : Longint; override;
end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);
var
tmp : pointer;
FHandle : THandle;
begin
FFormat := fmt;
OpenClipboard(0);
FHandle := GetClipboardData(FFormat);
FSize := GlobalSize(FHandle);
FMemory := AllocMem(FSize);
tmp := GlobalLock(FHandle);
MoveMemory(FMemory, tmp, FSize);
GlobalUnlock(FHandle);
FPosition := 0;
CloseClipboard;
end;

destructor TClipboardStream.Destroy;
begin
FreeMem(FMemory);
end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;
begin
if FPosition + Count > FSize then
Result := FSize - FPosition
else
Result := Count;
MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);
Inc(FPosition, Result);
end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;
var
FHandle : HGlobal;
tmp : pointer;
begin
ReallocMem(FMemory, FPosition + Count);
MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);
FPosition := FPosition + Count;
FSize := FPosition;
FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);
try
tmp := GlobalLock(FHandle);
try
MoveMemory(tmp, FMemory, FSize);
OpenClipboard(0);
SetClipboardData(FFormat, FHandle);
finally
GlobalUnlock(FHandle);
end;
CloseClipboard;
except
GlobalFree(FHandle);
end;
Result := Count;
end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
0 : FPosition := Offset;
1 : Inc(FPosition, Offset);
2 : FPosition := FSize + Offset;
end;
Result := FPosition;
end;

end.

[001122]


Delphi 1

Помещение изображения в буфер обмена II

Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения width, height, left и top, приведенные в коде, на реальные. Если вы действительно хотите вырезать, а не копировать область, то вам понадобиться ее залить с помощью вызова функции fillrect.

Var
BitMap : TBitmap;
begin
BitMap:=TBitMap.Create;
BitMap.Height:=BaseKeyPanel.Height;
BitMap.Width:=BaseKeyPanel.Width;
BitBlt(BitMap.Canvas.Handle, 0 {Лево}, 0{Top},
BaseKeyPanel.Width, BaseKeyPanel.Height,
GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
Clipboard.Assign(BitMap);
BitMap.Free
End;

[001806]


Хранение стилей шрифта

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,

Var
Style   : TFontStyles;
begin
{ Сохраняем стиль шрифта в байте }
Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство}
ByteValue := Byte ( Style );

{ Преобразуем значение byte в TFontStyles }
Canvas.Font.Style := TFontStyles ( ByteValue );
end;

Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.

- Robert Wittig [001117]


Delphi 1

Управление настройками шрифта

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

Расположите на форме Edit(Edit1) и ListBox(ListBox1).
Добавьте следующие элементы (Items) к ListBox:
fsBold
fsItalic
fsUnderLine
fsStrikeOut
}
 procedure TForm1.ListBox1Click(Sender: TObject);
var
X : Integer;
type
TLookUpRec = record
Name: String;
Data: TFontStyle;
end;
const
LookUpTable: array[1..4] of TLookUpRec =
((Name: 'fsBold'; Data: fsBold),
(Name: 'fsItalic'; Data: fsItalic),
(Name: 'fsUnderline'; Data: fsUnderline),
(Name: 'fsStrikeOut'; Data: fsStrikeOut));
begin
X := ListBox1.ItemIndex;
Edit1.Text := ListBox1.Items[X];
Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex+1].Data];
end;

[001487]


Письмо читателя

Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpyпаpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе. Все что я пpидyмал, это юзать glScale(), но в этом слyчае полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов

Из советов Nomadic'a:

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC( pData: Pointer )
//void GLSetupRC(void *pData)
//{
 var
//  HDC hDC;
hDC: HDC;
//  HFONT hFont;
hFont: HFONT;
//  GLYPHMETRICSFLOAT agmf[128];
agmf: array [0..127] of GLYPHMETRICSFLOAT;
//  LOGFONT logfont;
logfont: LOGFONT;

begin
logfont.lfHeight := -10;
logfont.lfWidth := 0;
logfont.lfEscapement := 0;
logfont.lfOrientation := 0;
logfont.lfWeight := FW_BOLD;
logfont.lfItalic := FALSE;
logfont.lfUnderline := FALSE;
logfont.lfStrikeOut := FALSE;
logfont.lfCharSet := ANSI_CHARSET;
logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
logfont.lfQuality := DEFAULT_QUALITY;
logfont.lfPitchAndFamily := DEFAULT_PITCH;
//strcpy(logfont.lfFaceName,"Arial");
//  strcpy(logfont.lfFaceName,"Decor");
StrPCopy( logfont.lfFaceName, 'Decor' );

glDepthFunc(GL_LESS);
glEnable(GL_DEPTH_TEST);  // Hidden surface removal
glFrontFace(GL_CCW);      // Counter clock-wise polygons face out
glEnable(GL_CULL_FACE);   // Do not calculate insides
glShadeModel(GL_SMOOTH);  // Smooth shading
glEnable(GL_AUTO_NORMAL);
glEnable(GL_NORMALIZE);
glEnable(GL_COLOR_MATERIAL);

glClearColor(0.0, 0.0, 0.0, 1.0 );

glEnable(GL_LIGHTING);
glLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight);
glLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight);
glLightfv(GL_LIGHT0,GL_SPECULAR,specular);
glLightfv(GL_LIGHT0,GL_POSITION,lightPos);
glEnable(GL_LIGHT0);

glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);
glMaterialfv(GL_FRONT, GL_SPECULAR,specular);
glMateriali(GL_FRONT,GL_SHININESS,100);

// Blue 3D Text
glRGB(0, 0, 255);

// Select the font into the DC
hDC := (HDC)pData;
//  hFont = CreateFontIndirect(&logfont);
hFont := CreateFontIndirect( Addr(logfont) );
SelectObject (hDC, hFont);

//create display lists for glyphs 0 through 255 with 0.3 extrusion
// and default deviation. The display list numbering starts at 1000
// (it could be any number).
//  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
//                            WGL_FONT_POLYGONS, agmf))
if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

//>                                         ``` - это тебе поможет
//> Выводить текст можно в любым масштабе
WGL_FONT_POLYGONS, agmf) then

Windows.MessageBox(nil,'Could not create Font Outlines',
'Error',MB_OK or MB_ICONSTOP);

// Delete the font now that we are done
DeleteObject(hFont);
//}
end;

// void GLRenderScene(void *pData)
procedure GLRenderScene(pData: Pointer);
begin
(*  ...  *)

// Draw 3D text
glListBase(1000);
glPushMatrix();
// Set up transformation to draw the string.
glTranslatef(-35.0, 0.0, -5.0) ;
glScalef(60.0, 60.0, 60.0);
glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
glPopMatrix();  // Clear the window with current clearing color

(* ... *)
end;

[001595]


Delphi 1

Различные разрешения - различные размеры шрифтов

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

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

  1. Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела.

    Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif.

  2. У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал.

    Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).

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

[001744]


Как получить список файлов, которые были перенесены на мою форму, например, из Проводника?

Из советов Nomadic'a:

Развлекался когда-то - вот, осталось:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShellAPI, Grids, StdCtrls;

type
TForm1 = class(TForm)
lb: TListBox;
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure WMDropFiles(var M: TMessage); message WM_DROPFILES;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

Var
CountFiles  : integer;
SizeName    : integer;
cch         : integer;

Var
hDrop : integer;
Point : TPoint;
lpszFile : PChar;

{$R *.DFM}

procedure TForm1.WMDropFiles(var M: TMessage);
Var
i: integer;
begin
hDrop := M.WParam;
DragQueryPoint(hDrop,Point);
CountFiles := DragQueryFile(hDrop, $FFFFFFFF, nil, cch);
for i:=0 to CountFiles-1 do
begin
SizeName   :=  DragQueryFile(hDrop, i, nil, cch);
GetMem(lpszFile,SizeName+1);
DragQueryFile(hDrop, i, lpszFile, SizeName+1);
lb.Items.Add(lpszFile);
FreeMem(lpszFile,SizeName+1);
end;
DragFinish(hDrop);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle,True);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
lb.Items.Clear;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShellAbout(Handle,'Anton Saburov','APSystems',0);
end;

end.

[001082]


Как пpинимать яpлыки пpи пеpетягивании их на контpол?

Из советов Nomadic'a:

TForm1 = class(TForm)
...
private
{ Private declarations }
procedure WMDropFiles(var M : TWMDropFiles); message WM_DROPFILES;
...
end;

var
Form1: TForm1;

implementation

uses
StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;;

procedure TForm1.FormCreate(Sender: TObject);
begin
...
DragAcceptFiles(Handle, True);
...
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
...
DragAcceptFiles(Handle, False);
...
end;

procedure TForm1.WMDropFiles(var M : TWMDropFiles);
var
hDrop: Cardinal;
n: Integer;
s: string;
begin
hDrop := M.Drop;
n := DragQueryFile(hDrop, 0, nil, 0);
SetLength(s, n);
DragQueryFile(hDrop, 0, PChar(s), n + 1);
DragFinish(hDrop);
M.Result := 0;
FileOpen(s);
end;

procedure TForm1.FileOpen(FileName: string);
begin
if CompareText(ExtractFileExt(FileName), '.lnk') = 0
then FileName := ResolveShortcut(Application.Handle, FileName);
DocName := ExtractFileName(FileName);
Caption := Application.Title + ' - ' + DocName;
...
end;

function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string;
var
obj: IUnknown;
isl: IShellLink;
ipf: IPersistFile;
pfd: TWin32FindDataA;
begin
Result := '';
obj := CreateComObject(CLSID_ShellLink);
isl := obj as IShellLink;
ipf := obj as IPersistFile;
ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ);
with isl do
begin
Resolve(Wnd, SLR_ANY_MATCH);
SetLength(Result, MAX_PATH);
GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY);
Result := PChar(Result);
end;
end;

[001709]


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

Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример:

function GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;

После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:

ListView_SetItemPosition(GetDesktopListViewHandle,i,x,y); {Не забудьте в uses добавить CommCtrl}

ярлыку с индексом i, задаст координаты (x,y). К примеру Мой компьютер имеет индекс 0, т.е i:=0;

С наилучшими пожеланиями, Сергей.
E-mail: ssa_sss@mail.ru

Nomadic дополняет:

К примеру, следующая строка кода:

SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );

разместит иконки рабочего стола по левой стороне рабочего стола Windows. [001074]


Как я могу использовать анимированный курсор?

Из советов Nomadic'a:

Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из элементов массива Cursors обьекта Screen.

Предопределенные курсоры имеют отрицательный индекс, а определенные пользователем (Вами) курсоры получают положительные индексы.

Ниже пример формы, использующей анимированный курсор:

procedure TForm1.Button1Click(Sender: TObject);
var
h: THandle;
begin
h := LoadImage(0,
'C:\TheWall\Magic.ani',
IMAGE_CURSOR,
0,
0,
LR_DEFAULTSIZE or
LR_LOADFROMFILE
);
if h = 0 then ShowMessage('Cursor not loaded')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;

[001127]


Как узнать текущее разрешение экрана?

Из советов Nomadic'a:

Советуем ознакомиться с Help topic относительно глобального обьекта Screen типа TScreen. У этого обьекта есть свойства Width и Height.

{ Example }
begin
iScreenWidth := Screen.Width;
end;

Заодно и другие свойства могут Вас заинтересовать, например, Fonts и Cursors. [001187]


Как изменить изображение кнопки `Пуск`

The_Sprite советует:

Пример из серии "Что можно сделать с рабочим столом". В общем, это обычный трюк с кнопкой "Пуск" (Start).

Совместимость: все версии Delphi

{ объявляем глобальные переменные }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ добавляем следующий код в событие формы OnCreate }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx

(FindWindow(
'Shell_TrayWnd',
nil),

0,'Button', nil);
OldBitmap := SendMessage(StartButton,

BM_SetImage, 0,

NewImage.Bitmap.Handle);
end;
{ Событие OnDestroy }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;

[001375]


Как программно заменить обои на рабочем столе? III

Igor Nikolaev aKa The Sprite советует:

program wallpapr;
uses Registry, WinProcs;
procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var
reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
//   Control Panel\Desktop
//     TileWallpaper (REG_SZ)
//     Wallpaper (REG_SZ)
reg := TRegIniFile.Create('Control Panel\Desktop' );
with reg do begin
WriteString( '', 'Wallpaper',
sWallpaperBMPPath );
if( bTile )then
begin
WriteString('', 'TileWallpaper', '1' );
end else begin
WriteString('', 'TileWallpaper', '0' );
end;
end;
reg.Free;
// Оповещаем всех о том, что мы изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,
{Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );
end;
// пример установки WallPaper по центру рабочего стола
SetWallpaper('c:\winnt\winnt.bmp', False );
//Эту строчку надо написать где-то в программе.

[001409]


Как программно заменить обои на рабочем столе? IV

Владимир Рыбант пишет:

Советы "Как програмно заменить обои на рабочем столе" I,II,III не изменяют обои, если в Windows работает в режиме Active Desktop

Нужно использовать следующее:

uses
ComObj,  ShlObj;

procedure ChangeActiveWallpaper;
const
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
ActiveDesktop: IActiveDesktop;
begin
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop)
as IActiveDesktop;
ActiveDesktop.SetWallpaper('c:\windows\forest.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;

Этим способом можно также изменять обои картинками jpg и gif [001543]


А как поместить свою иконку на taskbar, там где часы и переключатель клавиатуры?

Nomadic советует:

A: В библиотеке rxLib есть компонент TrxTrayIcon. Заметьте, что для корректного завершения работы операционной системе вам потребуется обрабатывать сообщение WM_QUERYENDSESSION. [001510]


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

Как ограничить перемещение курсора мыши какой-либо областью экрана?

Nomadic отвечает:

A: ClipCursor(). Учтите, что использование этой функции -- плохой тон. [001526]


Как узнать и поменять разрешение экрана?

Nomadic отвечает:

Поменять:

procedure ChangeDisplayResolution(x, y : word);
var
dm : TDEVMODE;
begin
ZeroMemory(@dm, sizeof(TDEVMODE));
dm.dmSize := sizeof(TDEVMODE);
dm.dmPelsWidth := x;
dm.dmPelsHeight := y;
dm.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
ChangeDisplaySettings(dm, 0);
end;

[001556]


Как запустить или закрыть скринсэйвер?

Nomadic приводит сиплюсплюсное решение:

Starting
~~~~~~~~
The method for starting a screen saver is simple, but surprising. You post your
own window a message ! Post yourself the WM_SYSCOMMAND message with the
SC_SCREENSAVE parameter :

   // Uses MFC CWnd::PostMessage
   PostMessage (WM_SYSCOMMAND, SC_SCREENSAVE);

Stopping
~~~~~~~~
Stopping a screen saver is somewhat more complex. The Microsoft-documented way
of doing this is to look for the special screen-saver desktop, enumerate all
windows on that desktop, and close them, as follows:

   hdesk = OpenDesktop(TEXT("Screen-saver"),
                       0,
                       FALSE,
                       DESKTOP_READOBJECTS | DESKTOP_WRITEOBJECTS);
   if (hdesk)
   {
      EnumDesktopWindows (hdesk, (WNDENUMPROC)KillScreenSaverFunc, 0);
      CloseDesktop (hdesk);
   }
   // ----------------------------------------------------------------

   BOOL CALLBACK KillScreenSaverFunc (HWND hwnd, LPARAM lParam)
   {
      PostMessage(hwnd, WM_CLOSE, 0, 0);
      return TRUE;
   }

However, I can't recommend this approach. I have found when using this code,
NT4 very occasionally seems to get confused and pass you back the normal
desktop handle, in which case you end up trying to close all the normal
application windows. Note, in MS' defence, that the code above for closing
32 bit savers is derived from a sample that is only marked as valid for
NT3.51 - there is no mention of NT4 in the sample. Unfortunately, there
is also nothing to indicate that it doesn't work properly.

I have subsequently performed some tests, and found that the stock screen
savers supplied with NT4 will in any case get a hit on the window class search
normally used for 16 bit savers ("WindowsScreenSaverClass"). I don't believe
for a moment that the OpenGL savers (for example) are 16 bit, so maybe MS are
supplying a saver window class that will give the necessary hit.
So anyway, you can use this route :

   HWND hSaver = FindWindow ("WindowsScreenSaverClass", NULL);

   if (hSaver)
      PostMessage (hSaver, WM_CLOSE, 0, 0);

Yet another alternative is now available, which depends upon new functionality
in SystemParametersInfo. This should be even more general :

   BOOL bSaver;
   if (::SystemParametersInfo (SPI_GETSCREENSAVEACTIVE,0,&bSaver,0))
   {
      if (bSaver)
      {
         ::PostMessage (::GetForegroundWindow(), WM_CLOSE, 0L, 0L);
      }
   }

So you can try that one as well. An embarassment of riches !

//***************************************************************************//
[001585]


Как пpогpаммно вывести окно свойств экpана?

Nomadic отвечает:

ShellExecute(Application.Handle, 'open', 'desk.cpl', nil, nil, sw_ShowNormal);

[001669]


Как поместить иконку в Tray?

Nomadic приводит следующий код:

function TaskBarAddIcon( hWindow : THandle; ID  : Cardinal;
ICON : hicon; CallbackMessage : Cardinal; Tip  : String ) : Boolean;
var
NID : TNotifyIconData;
begin
FillChar( NID, SizeOf( TNotifyIconData ), 0 );
with NID do begin
cbSize := SizeOf( TNotifyIconData );
Wnd   := hWindow;
uID    := ID;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
uCallbackMessage := CallbackMessage;
hIcon  := Icon;
if Length( Tip ) > 63 then SetLength( Tip, 63 );
StrPCopy( szTip, Tip );
end;
Result := Shell_NotifyIcon( NIM_ADD, @NID );
end;

[001681]


Пpоцедуpу котоpая убиpает или показывает кнопку "Стаpт" в выне...

Nomadic приводит следующий код:

Uses TypInfo;
Var
hTaskBar, hButton: HWND;
begin
hTaskBar:= FindWindow('Shell_TrayWnd', nil);
hButton:= GetWindow(hTaskBar, GW_CHILD);
// Hажать кнопку "Пуск"
SendMessage(hButton, WM_LBUTTONDOWN,
MK_LBUTTON,LoWord(5)+HiWord(Screen.Height-20));
// Убpать кнопку "Пуск"
ShowWindow(hButton, SW_HIDE);
// Показать кнопку "Пуск"
ShowWindow(hButton, SW_NORMAL);
end;

[001722]


Как добавить документы в папку `Старт`->`Документы`?

Олег Кулабухов приводит следующий код:

uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
var
s : string;
begin
s := 'C:\DownLoad\ntkfaq.html';
SHAddToRecentDocs(SHARD_PATH, pChar(s));
end;

[001786]


Как отключить хранитель экрана?

Олег Кулабухов приводит следующий код:

procedure TForm1.Button1Click(Sender: TObject);
begin
{Turn it off}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
0,
nil,
0);
{Turn it on}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
1,
nil,
0);
end;

[001829]


Как включить/отключить кнопку 'Старт'?

Олег Кулабухов приводит следующий код:

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

procedure TForm1.Button1Click(Sender: TObject);
var
Rgn : hRgn;
begin
{Hide the start button}
Rgn := CreateRectRgn(0, 0, 0, 0);
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
Rgn,
true);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Turn the start button back on}
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
0,
true);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
{Disable the start button}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
false);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
{Enable the start button}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
true);
end

[001833]


Иногда, мое приложение, работающее в трее, не убирает всплывающее меню после потери фокуса. Чем помочь?

Олег Кулабухов приводит следующий код:

Во время обработки сообщений PopUp меню, вы должны назначить активное окно, а потом после всплывания меню послать сообщение WM_NULL.

procedure TForm1.WndProc(var Msg : TMessage);
var
p : TPoint;
begin
case Msg.Msg of
WM_USER + 1:
case Msg.lParam of
WM_RBUTTONDOWN: begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
end;
end;
inherited;
end;

[001837]


Как очистить папку 'Документы' меню 'Старт'?

Олег Кулабухов приводит следующий код:

Просто используйте SHAddToRecentDocs() с параметром имени файла nil.

uses
ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;

[001841]


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

Тема: Использование InputBox, InputQuery и ShowMessage

Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi.

Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные.

Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия диалогового окна - кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery.

ShowMessage - другой простой путь отображения сообщения для пользователя.

procedure TForm1.Button1Click(Sender: TObject);
var s, s1: string;
b: boolean;
begin
s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey'));
b := s <> '';
s1 := s;

if b then
b := InputQuery('Повторите пароль', 'Пароль', s1);

if not b or (s1 <> s) then
ShowMessage('Пароль неверен');
end;

[001085]


Текст на кнопках MessageDlg

Как можно сменить текст на кнопках диалогового окна MessageDlg? Английский язык для текста кнопок пользователь хочет заменить на родной.

Текст кнопок извлекается из списка строк, расположенных в файле ...\DELPHI\SOURCE\VCL\CONSTS.PAS. Отредактируйте его, после чего пересоберите VCL.

-Steve Schafer

Дополнение

VS дополняет:

Но можно ничего не менять. Вместо MessageDlg использовать MessageBox - функция WINDOWS. И, если ваш WINDOWS русифицирован, то надписи на кнопках в диалоговых окнах будут на русском языке. [001121]


Delphi 1

Изменения в TOpenDialog

Почитайте про Open Dialog Box (диалоговое окно открытия файла) в файле помощи Windows API. Ознакомьтесь в статье с описанием аргумента lpTemplateName. Главное, вы можете создать новое диалоговое окно для Open Dialog Box и заменить стандартный диалог вашим собственным. [001474]


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

Как вывести диалог выбора каталога?

Nomadic советует:

A: (DS): SelectDirectory, rxLib: TDirectoryEdit. [001514]


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

Как вывести окно свойств компьютеpа?

Nomadic отвечает:

ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil, sw_ShowNormal);

[001671]


Delphi 1

Заголовок диалогового окна

Заголовок диалогового окна устанавливается в момент вызова CreateMessageDialog, чей код расположен в Dialogs.pas. При этом происходит вызов LoadStr, который получает Warningcaption, Cautioncaption и пр., так что у вас есть два пути: Или вы изменяете Dialogs.pas, или вы редактируете строки в .res-файле. [001738]


Delphi 1

Диалоги, модальные для всей системы

Ознакомьтесь с API-функцией SetSysModalWindow
Ознакомьтесь с API-функцией BringWindowToTop

Если вам необходим простой диалог с небольшим количеством текста, дополнительной иконкой и некоторыми кнопками, используйте MessageBox из WinProcs с MB_SYSTEMMODAL в параметре TextType.

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

procedure TForm1.Button1Click(Sender: TObject);
var
x : word ;
begin
x := SetSysModalWindow(AboutBox.handle) ;
AboutBox.showmodal ;
SetSysModalWindow(x) ;
end;

[001740]


Delphi 1

Процедура обертки диалогового окна объектом

Нужно создать новую форму со стилем Dialog, заполнить ее необходимыми компонентами, и использовать ее приблизительно таким образом:

with TMyForm.Create(self) do begin
Parent := Self;
MyExecute(inParam, outParam);
Release;
end;

где MyExecute() должен делать Show[Modal] и другие вещи... [001776]


Письмо читателя

Как запустить диалог поиска файла?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject);
begin
with TDDEClientConv.Create(Self) do begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties');
OpenLink;
ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False);
CloseLink;
Free;
end;
end;

[001844]


Письмо читателя

Как показать стандартное окно копирования файлов?

Своим опытом делится Олег Кулабухов:

Используйте SHFileOperation.

uses ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
var
Fo : TSHFileOpStruct;
buffer : array[0..4096] of char;
p : pchar;

begin
FillChar(Buffer, sizeof(Buffer), #0);
p := @buffer;
p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1;
StrECopy(p, 'C:\DownLoad\4.ZIP');

FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Handle;
Fo.wFunc := FO_COPY;
Fo.pFrom := @Buffer;
Fo.pTo := 'D:\';
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or
(Fo.fAnyOperationsAborted <> false)) then
ShowMessage('Cancelled')
end;

[001848]


Как послать самостийное сообщение всем главным окнам в Windows?

Nomadic советует:

Пример:

Var
FM_FINDPHOTO: Integer;

// Для того, чтобы использовать hwnd_Broadcast нужно сперва зарегистрировать уникальное
// сообщение.
Initialization
FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');

// Чтобы поймать это сообщение в другом приложении (приёмнике) нужно перекрыть DefaultHandler
 procedure TForm1.DefaultHandler(var Message);
begin
with TMessage(Message) do
begin
if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM)  else
Inherited DefaultHandler(Message);
end;
end;

// А теперь можно в приложении-передатчике
 SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);

Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast. [001133]


Как избавиться от торможения модальных окон?

Igor Nikolaev aKa The Sprite советует:

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

while Flag do
begin
PerformOperation;
Application.ProcessMessages;
Flag:=ContinueOperation;
end;

[001414]


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

Nomadic отвечает:

A: Application.ProcessMessages.

(AA): Если вы хотите отдавать timeslices в нитях, пользуйтесь Sleep(0); это отдаст остаток слайса системе.

(Win16) Если вы хотите разрешить отработку сообщений другим программам, но не вашей, то лучше пользоваться Yield(). [001516]


Как послать некое сообщение всем формам?

Nomadic предлагает следующий код:

var
I: Integer;
M: TMessage;
...
with M do begin
Message := ...
...
end;
for I := 0 to Pred(Screen.FormCount) do begin
PostMessage( Forms[I].Handle, ... );
// Если надо и всем чилдам
Forms[I].Broadcast( M );
end;

[001687]


Как сообщить какую-то глобальную переменную все (в т.ч. скрытым) окнам программы?

Своим опытом делится Олег Кулабухов:

Решением для такой задачи является рассылка пользовательского сообщения всем окнам массива Screen.Forms

{Code for Unit1}

const
UM_MyGlobalMessage = WM_USER + 1;

type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
{ Private declarations }
private
procedure UMMyGlobalMessage(var AMessage: TMessage); message
UM_MyGlobalMessage;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;

procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form1.Caption := 'Got It!';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
f: integer;
begin
for f := 0 to Screen.FormCount - 1 do
Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;

{Code for Unit2}

const
UM_MyGlobalMessage = WM_USER + 1;

type
TForm2 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure UMMyGlobalMessage(var AMessage: TMessage); message
UM_MyGlobalMessage;
public
{ Public declarations }
end;

var
Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form2.Caption := 'Got It!';
end;

[001847]


Метка диска под Win32

По моему глубокому убеждению для получения метки диска в среде Win95 необходимо использовать FindFile. Но это не работает, так?

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

- Peter Below [001056]


Восстанавление длинных имен файлов по известным коротким

boris советует:

//---------------------------------------------------------------------
// Восстанавливает длинные имена файлов по известным коротким (8.3)
// В качестве аргумента принимает полный или неполный (в т.ч. относительный)
// путь к файлу, например 'C:\WINDOWS\РАБОЧИ~1\ИТАКДА~1.LNK' или
// '..\..\COMMON~1\BORLAN~1\BDE\BDEREA~1.TXT'. Понимает сетевые имена.
// Возвращает полный(!) путь типа 'C:\Windows\Рабочий стол\и так далее.lnk',
// 'C:\Program Files\Common Files\Borland Shared\BDE\bdereadme.txt',
// '\\Computer\resource\Folder with long name\File with long name.ext'
//---------------------------------------------------------------------
Function RestoreLongName(fn: string): string;
function LookupLongName(const filename: string): string;
var sr: TSearchRec;
begin
if FindFirst(filename, faAnyFile, sr)=0 then Result:=sr.Name
else Result:=ExtractFileName(filename);
SysUtils.FindClose(sr);
end;
function GetNextFN: string;
var i: integer;
begin
Result:='';
if Pos('\\', fn)=1 then begin
Result:='\\';
fn:=Copy(fn, 3, length(fn)-2);
i:=Pos('\', fn);
if i<>0 then begin
Result:=Result+Copy(fn,1,i);
fn:=Copy(fn, i+1, length(fn)-i);
end;
end;
i:=Pos('\', fn);
if i<>0 then begin
Result:=Result+Copy(fn,1,i-1);
fn:=Copy(fn, i+1, length(fn)-i);
end else begin
Result:=Result+fn;
fn:='';
end;
end;
Var name: string;
Begin
fn:=ExpandFileName(fn);
Result:=GetNextFN;
Repeat
name:=GetNextFN;
Result:=Result+'\'+LookupLongName(Result+'\'+name);
Until length(fn)=0;
End;

[001034]


Как указать системе на необходимость сбросить буфера *.INI-файла на диск?

Nomadic советует:

procedure FlushIni(FileName: string);
var
{$IFDEF WIN32}
CFileName: array[0..MAX_PATH] of WideChar;
{$ELSE}
CFileName: array[0..127] of Char;
{$ENDIF}
begin
{$IFDEF WIN32}
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
begin
WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
CFileName, MAX_PATH));
end
else
begin
WritePrivateProfileString(nil, nil, nil, PChar(FileName));
end;
{$ELSE}
WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
FileName, SizeOf(CFileName) - 1));
{$ENDIF}
end;

[001106]


Копирование файлов III

Nomadic советует:

Можно так:

procedure CopyFile(const FileName, DestName: TFileName);
var
CopyBuffer: Pointer; { buffer for copying }
TimeStamp, BytesCopied: Longint;
Source, Dest: Integer; { handles }
Destination: TFileName; { holder for expanded destination name }
const
ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
Destination := ExpandFileName(DestName); { expand the destination path }
if HasAttr(Destination, faDirectory) then { if destination is a directory... }
Destination := Destination + '\' + ExtractFileName(FileName); { ...clone file name }
TimeStamp := FileAge(FileName); { get source's time stamp }
GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
try
Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError, [FileName]));
try
Dest := FileCreate(Destination); { create output file; overwrite existing }
if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError, [Destination]));
try
repeat
BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk }
if BytesCopied > 0 then { if we read anything... }
FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
until BytesCopied < ChunkSize; { until we run out of chunks }
finally
FileClose(Dest); { close the destination file }

{        SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp }{!!!}
end;
finally
FileClose(Source); { close the source file }
end;
finally
FreeMem(CopyBuffer, ChunkSize); { free the buffer }
end;
FileSetDate(Dest,FileGetDate(Source));
end;

Хм. IMHO кpутовато будет такие функции писать, когда в большинстве случаев достаточно что-нубудь типа нижепpиводимого, пpичем оно даже гибче, так как позволяет скопиpовать как весь файл пpи From и Count = 0, так и пpоизвольный его кусок.

function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;
var
InFS,OutFS: TFileStream;
begin
InFS  := TFileStream.Create( InFile,  fmOpenRead );
OutFS := TFileStream.Create( OutFile, fmCreate   );
InFS.Seek( From, soFromBeginning );
Result := OutFS.CopyFrom( InFS, Count );
InFS.Free;
OutFS.Free;
end;

try..except pасставляются по вкусу, а навоpоты вpоде установки атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны они в основном никогда.

Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation [001124]


Как получить имя папки pабочего стола (не чеpез registry)?

Nomadic советует:

Пpосто очень хочется поpаботать с shell functions.

В этом примере делается и это -

procedure TForm1.Button1Click(Sender: TObject);
procedure madd(s:string);
begin
memo1.lines.add(s);
end;
VAR
ppmalloc:imalloc;
id:ishellfolder;
pi:pitemidlist;
lpname:tstrret;
begin
if succeeded(shgetspecialfolderlocation(0,CSIDL_PROGRAMS,pi)) then
begin
madd('Succeeded programs location');
if succeeded(shgetdesktopfolder(id)) then
begin
madd('Succeeded get desktop folder');
if succeeded(id.getdisplaynameof(pi,0,lpname)) then
begin
madd('Succeeded get display name');
if lpname.uType=2 then
begin
madd(lpname.cstr);
end;
end
else
madd('UnSucceeded get display name');
end
else
madd('UnSucceeded get desktop folder');
end
else
madd('UNSucceeded programs location');
end;

[001183]


Количество строк в текстовом файле

Если файлы не слишком велики, вы можете сделать так:

List := TStringList.Create;
try
List.LoadFromFile('C:\FILE.TXT');
Gauge.MaxValue := List.Count;
finally
List.Free;
end;

Мы читаем в память весь текст, и кроме подсчета строк этот код ничего не делает. Другая идея заключается в использовании не счетчика строк, а счетчика байт. В самом начале вы запрашиваете размер файла (используя функцию Delphi FileSize), и в цикле проходите все байты, как вы делали это со строками. Цикл может выглядеть примерно так (предположим, вы используете стандартный паскалевский тип TEXT):

Gauge.MaxValue := FileSize(TextFile);
Reset(TextFile);
while not eof(TextFile) do
begin
Readln(TextFile, Line);

{ Обработка строки }

with Gauge do
begin
Progress := Progress + Length(Line) + 2; { 2 для CR/LF }
Refresh;
end;
end;

[001372]


Копирование файлов IV

Igor Nikolaev aKa The Sprite советует:

Copyfile('C:\1.txt','C:\files\2.txt',0);

где первый параметр - путь и имя нужного файла, а второй путь и имя нового(скопированого) файла

Если же необходимо задавать имена файлов через Edit, то:

Copyfile(PChar(edit1.text),PChar(edit2.text),0);

[001403]


Как в Delphi определить, где установлена Windows?

Nomadic отвечает:

GetWindowsDirectory

Пример:

var  Windir  : String;
WindirP : PChar;
................................................
WinDirP := StrAlloc(MAX_PATH);
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then WinDir := StrPas(WinDirP);
................................................

[001640]


Delphi 1

Слияние двух бинарных файлов

Самым простым способом является открытие первого, перемещение в его конец, и копирование с этого места второго файла.

Var
f1, f2 : File;
xfer   : Word;
buf    : PChar;
Begin
AssignFile(f1, name1);
Reset(f1);
Seek(f1, Filesize(f1));
AssignFile(f2, name2);
Reset(f2);
GetMem(buf, 65000);
Repeat
BlockRead(f1, buf^, 65000, xfer);
BlockWrite(f2, buf^, xfer);
Until xfer < 65000;
CloseFile(f1);
CloseFile(f2);
End;

[001675]


Delphi 1

Функция/процедура CopyFile

Модуль, который будет содердать этот код, должен иметь "LZExpand" в списке "uses" (без кавычек, естественно).

"var"-объявления:

SourceHandle, DestHandle: Integer;
SName,DName: String;

SName и DName содержат полные пути с именами целевого и исходного файлов.

В теле процедуры:

{устанавливаем десктипторы файлов}
SourceHandle := FileOpen(SName,0);
DestHandle := FileCreate(DName);

{устанавливаем буфер, выполняем копирование, очищаем буфер}
LZStart;
CopyLZFile(SourceHandle,DestHandle);
LZDone;

{закрываем файлы}
FileClose(SourceHandle);
FileClose(DestHandle);

[001678]


Delphi 1

Конец файла

Я не уверен в том, что вы используете eof() в правильном контексте. eof() просто ПРОВЕРЯЕТ, находитесь ли вы в конце "f"-файла. При этом вы никуда не перемещаетесь. А вот пример, как переместиться в конец файла:

procedure gotoeof (f : file);
{ прыгаем в конец (eof) }

begin
seek (f, 0);     { перемещаемся в начало }
seek (f, filesize(f));  { перемещаемся вперед на "x" количество байт, в нашем случае это размер файла! }
end; {gotoeof}

Eof() только проверяет, достигнут ли конец файла. Для установления файлового курсора на конец файла, вам необходимо использовать Seek() или SeekEof().
[001679]


Delphi 1

Файл типа TList

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

Обратите внимание на методы объекта ReadData и WriteData, используемые для его записи на диск, и методы SaveToFile и LoadFromFile самого TList. Правильным было бы сделать их более совместимыми (общими), но на это пока у меня не хватило времени. (Т.е., TList должен был бы восстанавливать/сохранять любой объект с помощью метода readdata/writedata.)

unit Charactr;

interface

uses
Graphics, StdCtrls, Classes, Sysutils, Winprocs, Ohmap, ohmstuff;

type
TMapCharacterList = class(TList)
private
FMap:TOverHeadMap;
public
procedure RenderVisibleCharacters; virtual;
procedure Savetofile(const filename:String);
procedure Loadfromfile(const filename:String);
procedure Clear;
destructor Destroy; override;
property MapDisp:TOverHeadMap read FMap write FMap;
end;

TFrameStore = class(TList)
procedure WriteData(Writer:Twriter); virtual;
procedure ReadData(Reader:TReader); virtual;
procedure Clear;
end;

TMapCharacter = class(TPersistent)
private
FName:string;
FMap:TOverHeadMap;
FFrame:Integer;
FFramebm,FFrameMask,FWorkBuf:TBitmap;
FFrameStore,FMaskStore:TFrameStore;
FXpos,FYpos,FZpos:Integer;
FTransColor:TColor;
FVisible,FFastMode,FIsClone,FRedrawBackground:Boolean;
procedure SetFrame(num:Integer);
function GetOnScreen:Boolean;
procedure SetVisible(vis:Boolean);
procedure MakeFrameMask(trColor: TColor);
procedure MakeFrameMasks; {Для переключения в быстрый режим...}
procedure ReplaceTransColor(trColor: TColor);
procedure SetXPos(x:Integer);
procedure SetYPos(y:Integer);
procedure SetZPos(z:Integer);
procedure SetFastMode(fast:Boolean);
public
constructor Create(ParentMap:TOverheadmap); virtual;
destructor Destroy; override;
property Name:string read FName write FName;
property Fastmode:Boolean read FFastMode write SetFastMode;
property FrameStore:TFrameStore read FFrameStore write FFramestore;
property MaskStore:TFrameStore read FMaskStore write FMaskStore;
property Frame:integer read FFrame write SetFrame;
property Framebm:TBitmap read FFramebm;
property FrameMask:TBitmap read FFrameMask;
property TransColor:TColor read FTransColor write FTransColor;
property Xpos:Integer read FXpos write SetXpos;
property YPos:Integer read FYpos write SetYpos;
property ZPos:Integer read FZpos write SetZpos;
property Map:TOverHeadMap read FMap write FMap;
property OnScreen:Boolean read GetOnScreen;
property Visible:Boolean read FVisible write SetVisible;
property IsClone:Boolean read FIsClone write FIsClone;
property RedrawBackground:Boolean read FRedrawBackground write
FRedrawBackground;

procedure Render; virtual;
procedure RenderCharacter(mapcoords:Boolean;cxpos,cypos:Integer;mask,bm,
wb:TBitmap); virtual;

procedure Clone(Source:TMapCharacter); virtual;

procedure SetCharacterCoords(x,y,z:Integer); virtual;
procedure WriteData(Writer:Twriter); virtual;
procedure ReadData(Reader:TReader); virtual;
end;

implementation

constructor TMapCharacter.Create(ParentMap:TOverheadmap);
begin
inherited Create;
FIsClone:=False;
FFramebm:=TBitMap.create;
FFrameMask:=TBitmap.Create;
FWorkbuf:=TBitMap.Create;
if Not(FIsClone) then
FFrameStore:=TFrameStore.Create;

FTransColor:=clBlack;
FFastMode:=False;
FMap:=ParentMap; end;

destructor TMapCharacter.Destroy;
var
a,b:Integer;
begin
FFramemask.free;
FFramebm.free;
FWorkBuf.Free;
if Not(FIsClone) then begin
FFrameStore.Clear;
FFrameStore.free;
end;

if (MaskStore<>nil) and Not(FIsClone) then begin
MaskStore.Clear;
MaskStore.Free;
end;
inherited Destroy; end;

{
Данная процедура копирует важную информацию из символа в себя
...
Стартуем невидимое клонирование, с нулевыми координатами карты.
}
procedure TMapCharacter.Clone(Source:TMapCharacter);
begin
FName:=Source.Name;
FFastMode:=Source.FastMode;
FFrameStore:=Source.FrameStore;
FMaskStore:=Source.MaskStore;
FTransColor:=Source.TransColor;
FMap:=Source.Map;
FVisible:=False;

Frame:=Source.Frame; {Ищем фрейм триггера.}

FIsClone:=True; end;

procedure TMapCharacter.SetXPos(x:Integer);
begin
Map.Redraw(xpos,ypos,zpos,-1);
FXpos:=x;
Render;
end;

procedure TMapCharacter.SetYPos(y:Integer);
begin
Map.Redraw(xpos,ypos,zpos,-1);
FYPos:=y;
Render;
end;

procedure TMapCharacter.SetZPos(z:Integer);
begin
Map.Redraw(xpos,ypos,zpos,-1);
FZpos:=z;
Render;
end;

procedure TMapCharacter.SetCharacterCoords(x,y,z:Integer);
begin
Map.Redraw(xpos,ypos,zpos,-1);
Fxpos:=x; Fypos:=y; Fzpos:=z;
Render;
end;

procedure TMapCharacter.SetFrame(num:Integer);
begin
if (num<=FFrameStore.count-1) and (num>-1) then begin
FFrame:=num;
FFramebm.Assign(TBitmap(FFrameStore.items[num]));
if Ffastmode=false then begin
FFrameMask.Width:=FFramebm.width;
FFrameMask.Height:=FFramebm.height;
FWorkBuf.Height:=FFramebm.height;
FWorkBuf.Width:=FFramebm.width;
makeframemask(TransColor);
replacetranscolor(TransColor);
end
else begin
FWorkBuf.Height:=FFramebm.height;
FWorkBuf.Width:=FFramebm.width;
FFrameMask.Assign(TBitmap(FMaskStore.items[num]));
end;
end;
end;

procedure TMapCharacter.MakeFrameMask(trColor: TColor);
var
testbm1,testbm2: TBitmap;
trColorInv: TColor;
begin
testbm1 := TBitmap.Create;
testbm1.width := 1;
testbm1.height:=1;
testbm2 := TBitmap.Create;
testbm2.width := 1;
testbm2.height:=1;
testbm1.Canvas.Pixels[0,0]:=trColor;
testbm2.Canvas.CopyMode:=cmSrcInvert;
testbm2.Canvas.Draw(0,0,testbm1);
trColorInv:=testbm2.Canvas.Pixels[0,0];
testbm1.free;
testbm2.free;
with FFrameMask.Canvas do
begin
Brush.Color:= trColorInv;
BrushCopy( Rect(0,0,FFrameMask.Width,FFrameMask.Height),FFramebm,
Rect(0,0,FFramebm.Width,FFramebm.Height),trColor);
CopyMode:=cmSrcInvert;
Draw(0,0,FFramebm);
end;
end;
procedure TMapCharacter.ReplaceTransColor(trColor: TColor);
begin
with FFramebm.Canvas do
begin
CopyMode:=cmSrcCopy;
Brush.Color:= clBlack;
BrushCopy( Rect(0,0,FFramebm.Width,FFramebm.Height),FFramebm,
Rect(0,0,FFramebm.Width,FFramebm.Height),trColor);
end;
end;

function TMapCharacter.GetOnScreen:Boolean;
var
dispx,dispy:Integer;
begin
dispx:=Map.width div map.tilexdim;
dispy:=Map.height div map.tileydim;
if (xpos>=Map.xpos) and (xpos<=map.xpos+dispx) and (ypos>=map.ypos) and
(ypos>=map.ypos+dispy) then
result:=true; end;

procedure TMapCharacter.SetVisible(vis:Boolean);
begin
if vis and OnScreen then Render;
FVisible:=vis;
end;

procedure TMapCharacter.SetFastMode(fast:Boolean);
begin
if fast<>FFastMode then begin
if fast=true then begin
FMaskStore:=TFrameStore.Create;
MakeFrameMasks;
FFastMode:=True;
frame:=0;
end
else begin
FMaskStore.Free;
FFastMode:=False;
end;
end;
end;

procedure TMapCharacter.MakeFrameMasks;
var
a:Integer;
bm:TBitMap;
begin
if FFrameStore.count>0 then begin
for a:=0 to FFrameStore.Count-1 do begin
Frame:=a;
bm:=TBitMap.create;
bm.Assign(FFrameMask);
FMaskStore.add(bm);
end;
end;
end;

procedure TMapCharacter.Render;
var
x,y:Integer;
begin
if visible and onscreen then
RenderCharacter(true,xpos,ypos,FFramemask,FFramebm,FWorkbuf);
end;

procedure TMapCharacter.RenderCharacter(mapcoords:Boolean;cxpos,cypos:
Integer;mask,bm,wb:TBitmap);
var
x,y:Integer;
begin
if map.ready then begin
{
Если пользователь определил это в mapcoords, то в первую очередь перерисовываем секцию(и). Если нет, делает это он.
}
if mapcoords then begin
if FRedrawBackground then
Map.redraw(cxpos,cypos,FMap.zpos,-1);
wb.Canvas.Draw(0,0,TMapIcon(FMap.Iconset[map.zoomlevel].items
[FMap.Map.Iconat(cxpos,cypos,Map.zpos)]).image);
x:=(cxpos-Map.xpos)*FMap.tilexdim;
y:=(cypos-Map.ypos)*FMap.tileydim;
end
else
wb.Canvas.Copyrect(rect(0,0,FMap.tilexdim,FMap.tileydim),FMap.
Screenbuffer.canvas,rect(x,y,x+FMap.tilexdim,
y+FMap.tileydim));

with wb do begin
Map.Canvas.CopyMode := cmSrcAnd;
Map.Canvas.Draw(0,0,Mask);
Map.Canvas.CopyMode := cmSrcPaint;
Map.Canvas.Draw(0,0,bm);
Map.Canvas.Copymode:=cmSrcCopy;
end;
Map.Canvas.CopyRect(Rect(x,y,x+FMap.tilexdim,y+FMap.tileydim),wb.
canvas,
Rect(0,0,FMap.tilexdim,FMap.tileydim));
end;
end;

procedure TMapCharacter.WriteData(Writer:TWriter);
begin
with Writer do begin
WriteListBegin;
WriteString(FName);
WriteBoolean(FFastMode);
WriteInteger(TransColor);
FFrameStore.WriteData(Writer);
if FFastMode then
FMaskStore.WriteData(Writer);
WriteListEnd;
end;
end;

procedure TMapCharacter.ReadData(Reader:TReader);
begin
with Reader do begin
ReadListBegin;
Fname:=ReadString;
FFastMode:=ReadBoolean;
TransColor:=ReadInteger;
FFrameStore.ReadData(Reader);
if FFastMode then begin
FMaskStore:=TFrameStore.Create;
FMaskStore.ReadData(Reader);
end;
ReadListEnd;
end;
end;

procedure TMapCharacterList.RenderVisibleCharacters;
var
a:Integer;
begin
for a:=0 to count-1 do
TMapCharacter(items[a]).render;
end;

procedure TMapCharacterList.clear;
var
obj:TObject;
begin
{Этот код освобождает все ресурсы, присутствующие в списке}
if self.count>0 then
begin
repeat
obj:=self.items[0];
obj.free;
self.remove(self.items[0]);
until self.count=0;
end;
end;

destructor TMapCharacterList.Destroy;
var
a:Integer;
begin
if count>0 then
for a:=0 to count-1 do
TObject(items[a]).free;
inherited destroy; end;

procedure TMapCharacterList.loadfromfile(const filename:string);
var
i:Integer;
Reader:Treader;
Stream:TFileStream;
obj:TMapCharacter; begin
stream:=TFileStream.create(filename,fmOpenRead);
try
reader:=TReader.create(stream,$ff);
try
with reader do begin
try
ReadSignature;
if ReadInteger<>$6667 then
Raise EReadError.Create('Не список сиволов.');
except
Raise EReadError.Create('Неверный формат файла.');
end;
ReadListBegin;
while not EndofList do begin
obj:=TMapCharacter.create(FMap);
try
obj.ReadData(reader);
except
obj.free;
raise EReadError.Create('Ошибка в файле списка символов.');
end;
self.add(obj);
end;
ReadListEnd;
end;
finally
reader.free;
end;
finally
stream.free;
end;
end;

procedure TMapCharacterList.savetofile(const filename:String);
var
Stream:TFileStream;
Writer:TWriter;
i:Integer;
obj:TMapCharacter; begin
stream:=TFileStream.create(filename,fmCreate or fmOpenWrite);
try
writer:=TWriter.create(stream,$ff);
try
with writer do begin
WriteSignature;
WriteInteger($6667);
WriteListBegin;
for i:=0 to self.count-1 do
TMapCharacter(self.items[i]).writedata(writer);
WriteListEnd;
end;
finally
writer.free;
end;
finally
stream.free;
end;
end;

procedure TFrameStore.WriteData(Writer:TWriter);
var
mstream:TMemoryStream;
a,size:Longint;
begin
mstream:=TMemoryStream.Create;
try
with writer do begin
WriteListBegin;
WriteInteger(count);
for a:=0 to count-1 do begin
TBitmap(items[a]).savetostream(mstream);
size:=mstream.size;
WriteInteger(size);
Write(mstream.memory^,size);
mstream.position:=0;
end;
WriteListEnd;
end;
finally
Mstream.free;
end;
end;

procedure TFrameStore.ReadData(Reader:TReader);
var
mstream:TMemoryStream;
a,listcount,size:Longint;
newframe:TBitMap;
begin
mstream:=TMemoryStream.create;
try
with reader do begin
ReadListBegin;
Listcount:=ReadInteger;
for a:=1 to listcount do begin
size:=ReadInteger;
mstream.setsize(size);
read(mstream.Memory^,size);
newframe:=TBitmap.create;
newframe.loadfromstream(mstream);
add(newframe);
end;
ReadListEnd;
end;
finally
Mstream.free;
end;
end;

procedure TFrameStore.clear;
var
Obj:TObject;
begin
{{Этот код освобождает все ресурсы, присутствующие в списке}
if self.count>0 then
begin
repeat
obj:=self.items[0];
obj.free;
self.remove(self.items[0]);
until self.count=0;
end;
end;

end.

[001680]


Delphi 1

Вопросы разделяемого доступа к файлу

А вы пробовали использовать блок try ... except?

Недавно я решал аналогичную задачу.

Код на основе приведенного ниже скелета отлично справлятеся с поставленной задачей...

try
{здесь размещается код работы с открытым файлом}
...
except
{здесь располагается код обработки исключений}
{что-то типа MessageDlg('Не могу открыть файл', mtError, [mbOk], 0)
или что-либо получше :) }
...
end;

Для EXE & COM файлов может использоваться так называемый сетевой Shareable-атрибут, который позволяет нескольким пользователям выполнять один файл. Для текстовых файлов это не работает.

Единственный метод должен проверять наличие атрибута DOS "READ-ONLY" (только для чтения). Множество DOS & Windows программ устанавливают этот флаг после того, как они откроют файл, чтобы таким образом предотвратить к нему доступ из других программ. В качестве альтернативы, можно проверять атрибут файла NETWARE "READ-ONLY". Проверку можно организовать с помощью компонентов NETWARE API, обеспечивающими работу с сетевыми функциями. Если ваша программа находит одно из этих двух условий истинным, следует подождать некоторое время, и проверить его снова, прежде чем пытаться получить доступ к файлу. [001682]


Delphi 1

Разбиение и сборка файла

Не так сложно, вот как это может выглядеть:

inf:   file;
outf:  file;
size:  longint;
outsize: longint;
amt:    word;
amtRead: word;

assignfile (inf, 'входной файл');
reset (inf, 1);
size := fileSize (inf);
repeat
showMessage ('Вставьте дискету в дисковод "A"')  { или "B", а лучше позвольте их определять }
assignFile (outf, 'A: выходной файл');
rewrite (outf, 1);
outsize := diskFree (1);  { или 2, если это дисковод "B" }
while (outsize > 0) and (size > 0) do begin
amt := sizeof(buf);
if amt > outsize then amt := outsize;
blockRead (inf, buf, amt, amtRead);
blockWrite (outf, buf, amtRead);
dec (outSize, amtRead);
dec (size, amtRead);
end;
closeFile (outf);
until size <= 0;
closeFile (inf);

Писалось все "от руки", поэтому синтаксис может быть с ошибками. Правильным было бы добавление кода, который позволит пользователю определить используемый дисковод ("A" или "B"), задание именной схемы для восстановления информации, если один из дисков испортится и пр.

Сборка происходит аналогично: открываем на диске выходной файл, просим пользователя вставить дискетту, blockRead/blockWrite с дискеты на жесткий диск, просим пользователя вставить другую дискету, пока куски файла не считаются полностью. [001684]


Delphi 1

Исправление ошибки записи на файл полей с данными

Вот самый простой способ сделать это (никто не спорит, может быть существует лучший способ):

var F : TextFile;
S : String;

AssignFile(F, 'FILENAME.TXT');
Reset(F);
while Not EOF(F)
do    begin
Readln(F, S);
V1:= Copy(S,1,3);
V2:= Copy(S,4,6);
...
end;
CloseFile(F);

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


Delphi 1

Получение размера файла

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

var
Fhnd2 : File ;
sPath : String;
tpath : string;
SearchRec: TSearchRec;
tempsearch : string;
tempfiles : Integer;
tempbytes : LongInt;
wBytes : Word;
sTemp : String ;
iLen : Integer ;
szString: Array[0..128] Of Char;
ec : integer;

BEGIN

{* Выбираем системный каталог *}
MailManLogS('Запуск MailMan');
sTemp := ParamStr(0) ;
iLen := Length(sTemp) ;
WHILE sTemp[iLen] <> '\' DO
DEC (iLen) ;
StrPCopy(szString, sTemp) ;
szString[iLen] := #0 ;
SysDir := StrPas(szString) ;

tempbytes := 0;
tempfiles := 0;
Files2bProc := 0;
Bytes2bProc := 0;
MailManLogS('Калькулируем файлы для обработки');
{* Подсчитываем, сколько файлов и байт должны быть обработаны *}
tempsearch := SysDir + 'spool\witchcrf\d\*.*' ;
ec := FindFirst(tempsearch, faSysFile, SearchRec);
While ec = 0 do
begin
if ((SearchRec.Name <> '.') and (SearchRec.Name <> '..')) then
begin
tempfiles := tempfiles + 1;
---->     tempbytes := tempbytes + SearchRec.Size;       <------
TotalInBytes.Text := IntToStr(tempbytes);
TotalInFiles.Text := IntToStr(tempfiles);
MailManLogS('Файл-' + SearchRec.Name + '     Размер-' + IntToStr(SearchRec.Size));

end;
ec := FindNext(SearchRec);
end;

MailManLogS('Всего файлов = ' + IntToStr(tempfiles) + '        Байт = ' + IntToStr(tempbytes));

end;

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

Я все это делал с использованием FindFirst. Функция возвращает запись, имеющую тип TSearchRec. Данная запись содержит переменную Size, которая содержит размер файла в байтах. Это может быть не так красиво, но это работает:

function GetFileSize(FileName: string): Longint;
var
SearchRec: TSearchRec;
begin
if FindFirst(FileName, faAnyFile, SearchRec) = 0 then
Result:=SearchRec.Size
else
Result:=-1;       {возвращаем ошибку, это может быть число меньше нуля}
end;

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

Function FileGetSize1(Filename : String) : LongInt;
var
F : File;
OldFileAttr : Integer;
begin
if FileExists(Filename)
then
begin
OldFileAttr := FileGetAttr(Filename);
FileSetAttr(Filename,OldFileAttr and (faReadOnly xor $FFFF));
try
AssignFile(F, Filename);
Reset(F,1);
Result := FileSize(F);
CloseFile(F);
finally
FileSetAttr(Filename, OldFileAttr);
end;
end
else
Result := 0;
end;

Function FileGetSize2(Filename : String) : LongInt;
var
FileHandle : Integer;
begin
if FileExists(Filename)
then
begin
FileName := FileName + chr(0);
FileHandle := _lopen(@FileName[1], 0);
Result := _llseek(FileHandle, 0, 2);
_lclose(FileHandle);
end
else
Result := 0;
end;

[Eric Nielsen, htrsoft@midwest.net]

Я не стал возиться с AssignFile.

Function FileSizeInBytes(YourFile : String) : LongInt;
Var
F : Integer;
Begin
F:=FileOpen(YourFile,0);  { режим ReadOnly }
FilesizeInBytes := FileSeek(F,0,2);
FileClose(F)
End;

Примечание: Проверка ошибок отсутствует !!! [001688]


Delphi 1

Переименование каталога

Функция RenameFile (модуль SysUtils) работает как для файлов, так и для каталогов. [001690]


Delphi 1

Импорт больших файлов с разделителями

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

var s: String; f: TextFile;
AssignFile(f, 'D:\INPUT.TXT');
Reset(f);
while not EOF(f) do
begin
ReadLn(s, f);
ShowMessage(GetField(s, 1));  {Первое поле}
ShowMessage(GetField(s, 6));  {Шестое поле}
ShowMessage(GetField(s, 25)); {возвратит '', если нет 25 колонки...}
end;
CloseFile(f);

{ ==== Данная функция возвращает поле из строки с разделителем. ==== }
function GetField(InpString: String; fieldpos: Integer): String;
var
c: Char;
curpos, i: Integer;
begin
curpos := 1;
for i := 1 to fieldpos do
begin
result := ''; if curpos > Length(InpString) then Break;
repeat
c := InpString[curpos]; Inc(curpos, 1);
if (c = '"') or (c = #13) or (c = #10) then c := ' ';
if c <> ',' then result := result + c;
until (c = ',') or (curpos > Length(InpString))
end;
if (curpos > Length(InpString)) and (i < fieldpos) then result := '';
result := Trim(result);
end;

{ ==== Данная функция удаляет у строки левые и правые пробелы. ==== }
function Trim(inp_str: String): String;
var
i: Integer;
begin
for i := 1 to Length(inp_str) do if inp_str[i] <> ' ' then Break;
if i > 1 then Delete(inp_str, 1, i - 1);
for i := Length(inp_str) downto 1 do if inp_str[i] <> ' ' then Break;
if i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str));
result := inp_str;
if result = ' ' then result := '';
end;

[001691]


Delphi 1

Итерация подкаталогов

procedure TFormList.RecurseDir(PathInicial: string);
var
SearchRec: TSearchRec;
Result: integer;
tmpName: string;
begin
DirectoryListBox1.Directory:=PathInicial;
Result:=FindFirst(PathInicial+'\*.*', faAnyFile, SearchRec);
While Result = 0 do begin
if ExtOk(SearchRec.Name) then
{ если каталог... }
if SearchRec.Attr and faDirectory > 0 then
{ рекурсивно обрабатываем... }
RecurseDir(PathInicial+'\'+SearchRec.Name)
else begin
tmpName:=PathInicial+'\'+SearchRec.Name;
tmpName:=Copy(tmpName,
Pos(PathOrigen,tmpName)+Length(PathOrigen),
Length(tmpName)-Length(PathOrigen));
ListBox1.Items.Add(LowerCase(tmpName));
end;
Application.ProcessMessages;
Result:=FindNext(SearchRec);
end;
DirectoryListBox1.Directory:=PathInicial;
end;

[001693]


Delphi 1

Открытие файла только на чтение

Перед открытием или созданием файла, установите переменную FileMode. Чтобы установить ее, воспользуйтесь 'File Open Mode constants' (константы режима открытия файла). Взгляните на описание модуля Sysutils. Где-то во второй части описания находится перечень 'File Open Mode constants'. Вот они-то как раз и используются в переменной FileMode. Константы лучше связывать логическим оператором OR... например с fmOpen... или с константой fmShare... константы устанавливают режим.

Ознакомьтесь в файле помощи с описанием переменной FileMode. Если перед открытием файла вы установили ее в ноль, файл будет открыт только для чтения. По-умолчанию read/write (чтение/запись) для нетипизированных файлов.

Вы можете просто попробовать установить filemode после того, как сделаете файлу assign. Например:

AssignFile(F, FileName);
FileMode := 0;  { устанавливаем доступ к файлу только для чтения }
Reset(F);
.
.
.
CloseFile(F);

[001695]


Delphi 1

Чтение данных из файла

Имеется процедура Flush, которая работает с открытыми файлами:

flush(f);

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

Ниже дан пример:

Uses
Sysutils;
var
F    : text;             { это ваш текстовый файл }
Procedure TextFlush(F : Text);
var
fhandle   : word;
begin
Flush(F);
fhandle := ttextrec(F).Handle;       { получаем дескриптор msdos }
asm
mov  ax, $6800
mov  bx, handle
call DOS3CALL
end;
end;

Если файл является "блочным" файлом, пропускаем шаг с командой flush, и используем tfilerec вместо ttextrec.

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

Assign, или AssignFile, как вы теперь знаете, не может использоваться с файлом, который уже открыт (я проверял это, и это действительно так). В вашем случае рекомендую обратиться к вызову API OpenFile, ничего в этом страшного нет.

Если это текстовый файл, сбросьте сначала текстовый буфер на диск командой flush:

flush(f)

Остальное относится ко всем файлам:

Сделайте файлу commit, используя dos-функцию commit, доступную начиная с DOS 5.

asm
mov  ax, $6800                { делаем commit файла }
mov  bx, ttextrec(f).handle   { получаем дескриптор файла }
call dos3call                 { это предпочтительный способ,  INT $21 также должно работать }
end;

Согласно документации Microsoft, данный вызов также сбрасывает буфера SMARTDRIVE. MSDN10 так описывает алгоритм реализации этого на языке приложения:

Для сброса данных, сохраняемых в буфере SMARTDRV.EXE версии 4.0, вы можете воспользоваться одним из следующих способов:

  • Используйте функцию MS-DOS Commit File (которая записывает измененные данные буфера). Это прерывание 21h, функция 68h.
  • Используйте функцию MS-DOS Disk Reset (которая записывает измененные данные и чистит кэш). Это прерывание 21h, функция 0Dh.
[001697]


Delphi 1

Чтение и запись данных в/из файлов

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

Для оформления программы необходимо установить на форме
компонент TMemo с заголовком Запись, и кнопку с заголовком
Чтение. Запустите программу, поместите несколько строк в "memo",
после чего нажмите на кнопку Запись. Очистите "memo", и нажмите Чтение.
}
procedure TForm1.BtnWriteClick(Sender: TObject);
{ автор: Michael Vincze
}
var
FileStream: TFileStream;
Writer    : TWriter;
I         : Integer;
begin
FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt',
fmCreate or fmOpenWrite or fmShareDenyNone);
Writer := TWriter.Create (FileStream, $ff);
Writer.WriteListBegin;
for I := 0 to Memo1.Lines.Count - 1 do Writer.WriteString (Memo1.Lines[I]);
Writer.WriteListEnd;
Writer.Destroy;
FileStream.Destroy;
end;

procedure TForm1.BtnReadClick(Sender: TObject);
{ автор:  Michael Vincze
}
var
FileStream: TFileStream;
Reader    : TReader;
begin
{ пробуем открыть несуществующий файл
}
try
FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\bogus.txt',
fmOpenRead);
except
; { Destroy не нужен, поскольку Create потерпела неудачу  }
end;

FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt',
fmOpenRead);
Reader := TReader.Create (FileStream, $ff);
Reader.ReadListBegin;
Memo1.Lines.Clear;
while not Reader.EndOfList do Memo1.Lines.Add (Reader.ReadString);
Reader.ReadListEnd;
Reader.Destroy;
FileStream.Destroy;
end;

[001698]


Чтение и запись файлов

1) Направление выходного потока вашей программы в файл.
2) Направление выходного потока вашей программы на принтер.
3) Чтение из входного файла.

Направление выходного потока вашей программы в файл

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

Просто в Delphi ....

program CrtApp;
uses WinCrt;
var outfile: TextFile;
begin
AssignFile(outfile, 'c:\outfile.txt');
Rewrite(outfile);
writeln(outfile, 'Привет из Delphi');
writeln(outfile, 'Моя программа работает, и выводит ' +
'данный текст, чтобы доказать это...');
CloseFile(outfile);
end.

Просто в Паскале.....

Program HelloWorld;
var
outfile: text;
begin
assign(outfile, 'c:\output.txt');
rewrite(outfile);
writeln(outfile, 'Здравствуй, мир');
writeln(outfile, 'Моя программа работает, и выводит
данный текст, чтобы доказать это...');
close(outfile);
end.

Направление выходного потока вашей программы на принтер

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

В Delphi ...

program CrtApp;
uses WinCrt;
var outfile: TextFile;
begin
assignfile(outfile, 'LPT1');
rewrite(outfile);
writeln(outfile, 'Привет из Delphi');
writeln(outfile, 'Моя программа работает, и выводит ' +
'данный текст, чтобы доказать это...');
closefile(outfile);
end.

В Паскале ...

Program HelloWorld;
var
outfile: text;
begin
assign(outfile, 'LPT1');
rewrite(outfile);
writeln(outfile, 'Здравствуй, мир');
writeln(outfile, 'Моя программа работает, и выводит
данный текст, чтобы доказать это...');
close(outfile);
end.

Чтение из входного файла

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

В Delphi ...

program CrtApp;
uses WinCrt;
var
infile, outfile: TextFile;
num_lines, x: integer;
line: string;
begin
assignfile(infile, 'C:\INFILE.TXT');
assignfile(outfile, 'C:\OUTFILE.TXT');
reset(infile);  {перемещаем указатель}
{в начало файла.}
rewrite(outfile);  {очищаем содержимое файла}
readln(infile, num_lines);
for x:= 1 to num_lines do
begin
readln(infile, line);
writeln(outfile, line);
end;
closefile(infile);
closefile(outfile);
end.

В Паскале ...

Program ReadInput;
var
infile, outfile: text;
num_lines, x: integer;
line: string;
begin
assign(infile, 'C:\INFILE.TXT');
assign(outfile, 'C:\OUTFILE.TXT');
reset(infile);  {перемещаем указатель}
{в начало файла.}
rewrite(outfile);  {очищаем содержимое файла}
readln(infile, num_lines);
for x:= 1 to num_lines do
begin
readln(infile, line);
writeln(outfile, line);
end;
close(infile);
close(outfile);
end.

{НАЧАЛО INFILE.TXT}
2
Здравствуй, мир
Моя программа работает, и этот текст доказательство этому.
{КОНЕЦ INFILE.TXT}
Для получения дополнительной информации обратитесь к Руководству Разработчика. Ознакомьтесь с описанием функций AssignFile, Assign, Reset, Rewrite, readln, writeln, Close, CloseFile.

Данный документ был написан автором под впечатлением просьбы умоляющего студента и чувством симпатии к нему, поскольку он сам недавно сидел на студенческой скамье..!! [001699]


Чтение бинарного файла

var
f: File;
c: Char;
begin
AssignFile(f, 'this.bin');
Reset(f, 1);
BlockRead(f, c, sizeof(c));
CloseFile(f);
end;

function FindInFile( cFileName : string; cCh : char ) : boolean;
var fFile  : file;
aBuf   : array[1..1024] of char;
lFound : boolean;
x,
nRead  : integer;
begin
Assign( fFile, cFileName );
Reset( fFile, 1 );

lFound := False;

repeat
BlockRead( fFile, aBuf, SizeOf( aBuf ), nRead );

x := 1;
while not lFound and ( x <= nRead ) do
begin
lFound := ( aBuf[ x ] = cCh )
Inc( x )
end;
until ( nRead < SizeOf( aBuf ) ) or lFound;

FindInFile := lFound
end;

Взгляните на следующий код:

var
f: file;
c: Char;
begin
AssignFile(f, 'c:\autoexec.bat');
Reset(f, 1);                        <- Примечание: Размер записи = 1 байту это нормально!
while not Eof(f) do
begin
BlockRead(f, c, SizeOf(c));
{Теперь обрабатываем c}
end;
CloseFile(f);
end;

Для ускорения этой процедуры не следует за один проход читать по одному символу. Возможно, лучшим решением будет объявление PChar скажем, размером 200, и чтением за один проход блоков размером 200 байт. {например, BlockRead(f, p, 200);} Но для этого требуется немного больше кода, чем показано здесь... (Используйте все тот же recordsize, равный 1, меняется только blocksize). [001701]


Delphi 1

Чтение из файла длинной строки

Для решения этой задачи на помощь можно призвать потоки (TFileStream, TMemoryStream). Для поиска конца строк нужно искать пары CR/LF, но это делается очень легко, приблизительно так (я сегодня вечером слишком ленивый для реального кода):

Start := Stream.Position;
End := Start;
Repeat
Stream.Read(Buffer^, 1024);
CRPos := FindCR(Buffer^);   { где FindCR возвращает 0..1023 для CR,
и 1024, если он не найден}
Inc(End, CRPos);
Until CRPos < 1024;
GetMem(MyPChar, End - Start);  { Здесь может быть +-1 -- мне лень сегодня проверять! } Stream.Seek(Start);
Stream.Read(MyPChar^, End - Start)

Затем установите CR в конце MyPChar в 0, и сделайте Seek в конец (End + 1), или что-то еще, чтобы пропустить LF.

LazyMan [001703]


Delphi 1

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

{
Здесь я привожу немного сокращенный код, который я создавал для Borland
Pascal 5.5 под DOS (оригинальный код не делал rmDir, поэтому вы можете
поэкспериментировать с этим, передав указатель на каталог функции rmDir
в конце этого кода). Я подозреваю, что Delphi-версия может быть или
идентичной, или иметь некоторые различии в написании имен функций
(рекомендую ознакомиться с электронной документацией по Delphi, с темой,
где описаны функции для работы с файлами). Данный код не предусматривает
проверку атрибутов файлов, которые могут быть установлены для
предотвращения удаления файла. (В Pascal 5.5 вам необходимо между парой
{$I-} {$I+} поместить функцию, которая вызывает проблему, не знаю,
делаете ли вы это в Delphi.)
}
procedure removeTree (DirName: string);
var
FileSearch:  SearchRec;
begin
{ для начала пробегаемся, и удаляем все файлы }
chDir (DirName);
FindFirst ('*.*', Directory, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND
( (FileSearch.attr AND Directory) <> 0)
then begin
if DirName[length(DirName)] = '\' then
removeTree (DirName+FileSearch.Name)
else
removeTree (DirName+'\'+FileSearch.Name);
ChDir (DirName);
end;
FindNext (FileSearch)
end;

{ затем пробегаемся, и удаляем все каталоги }
FindFirst ('*.*', AnyFile, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') then
Remove (workdir);
end;
FindNext (FileSearch)
end;
rmDir (DirName)
end;

[001705]


Delphi 1

Сохранение в файле пятисот символов из массива

Следующий код может помочь вам начать.

Type
TCharArray = Array[500] of Char;
Procedure WriteToFile(Var aArray : TCharArray; sFileName : String); {Примечание:
Объявление массива как параметр Var позволяет передавать только ссылку на массив,
а не копировать его целиком в стек, если же вам нужна безопасная работа с массивом,}
то вам не следует передавать его как Var-параметр.}
Var
nArrayIndex : Word;
fFileHandle : TextFile;
Begin
AssignFile(fFileHandle, sFileName);
Rewrite(fFileHandle);

For nArrayIndex := 1 to 500 Do
Begin
Write(fFileHandle, aArray[nArrayIndex]); End;

CloseFile(fFileHandle);
End; {end Procedure, WriteToFile()}

[001707]


Delphi 1

Установка времени и даты файла

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

var
f: file;
begin
Assign(f, DirInfo.Name);
Reset(f);
SetFTime(f, Time);
Close(f);
end;

[001710]


Delphi 1

Установка времени компиляции программы в диалоговом окне "О программе".

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

Var
F : Integer;
S : String;
Begin
F:=FileOpen(ExpandFileName(Application.ExeName), 0);
S:=TimeToStr(FileDateToDateTime(FileGetDate(F)));
FileClose(F);
End;

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

Также можно использовать время файла (File Time) в качестве номера версии, так, время 6:02 обозначало бы версию 6.02, и устанавливать его чем-то типа Touch. [001712]


Delphi 1

Медленное копирование с диска на дискетту и обратно

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

Пример процедуры копирования файла copyfile:

Function CopyFile(FromPath,ToPath : String) : integer;

Var
F1          : file;
F2          : file;
NumRead     : word;
NumWritten  : word;
Buf         : pointer;
BufSize     : longint;
Totalbytes  : longint;
TotalRead   : longint;

Begin
Result := 0;
Assignfile(f1,FromPath);
Assignfile(F2,ToPath);
reset(F1,1);
TotalBytes := Filesize(F1);
Rewrite(F2,1);
BufSize := 16384;
GetMem(buf,BufSize);
TotalRead :=0;
repeat
BlockRead(F1, Buf^, BufSize, NumRead);
inc(TotalRead,NumRead);
BlockWrite(F2, Buf^, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
if (NumWritten <> NumRead) then
begin
{ошибка }
result := -1;
end
closefile(f1);
Closefile(f2);
End;

Если у вас есть file of byte (бинарный файл), или просто File, вы должны использовать Blockread, который позволяет устанавливать размер буфера, равный 64Кб. Ниже я предоставляю вашему вниманию "быстрый" способ достижения цели. Воспользуйтесь Compress (который, я надеюсь, вы найдете в поставке Delphi, в противном случае обратитесь на сайт Microsoft), который позволит вам создавать файлы типа filename.ex_. Это означает, что для копирования информации требуется гораздо меньше усилий.

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

function TInstallForm.UnCompress(src, dest: String; Var Error : LongInt):
Boolean;
var
s, d: TOFStruct;
fs, fd: Integer;
fnSrc, fnDest: PChar;
begin
src:=src + #0;
dest:=dest + #0;
fnSrc:=@src[1];   { Хитро преобразуем строки в ASCIIZ }
fnDest:=@dest[1];

fs := LZOpenFile(fnSrc, s, OF_READ);    { Получаем дескриптор файла }
fd := LZOpenFile(fnDest, d, OF_CREATE);

Error:=LZCopy(fs, fd);           { Вот магический вызов API }
Result:=(Error > -1);

LZClose( fs );    { Убедитесь, что закрыли! }
LZClose( fd );
end;

Procedure UnCompressError(Error : LongInt);
Begin
Case Error Of
LZERROR_BADINHANDLE : S:='Неверный дескриптор
исходного файла';
LZERROR_BADOUTHANDLE: S:='Неверный дескриптор
целевого файла';
LZERROR_BADVALUE    : S:='Входной параметр вышел за
границы диапазона';
LZERROR_GLOBALLOC   : S:='Недостаточно памяти
для требуемого буфера';
LZERROR_GLOBLOCK    : S:='Неверный дескриптор
структуры внутренних данных';
LZERROR_READ        : S:='Неверный формат исходного файла';
LZERROR_UNKNOWNALG  : S:='Исходный файл был упакован
с использованием неизвестного алгоритма сжатия';
LZERROR_WRITE       : S:='Недостаточно места для выходного файла'
Else
S:='Неизвестная проблема с распаковкой'
End;
MessageDlg(S, mtConfirmation,[mbOK],0);
Close
End;

function CopyFile( SrcName,DestName : string ): boolean;
{ базовый метод копирования файла; требует
полный путь & имя для исходного & целевого файла }
 var
Buf: array[1..1024*4] of byte;   { этот размер может быть изменен..
объявляя указатель, вы можете использовать GetMem для создания в куче большого буфера }
TotalRead: longint;
NumRead,
NumWritten: word;
TotalWritten: longint;
FromFileSize: longint;
FrF,ToF :    file;
FileTime :    longint;
begin

FGetTime(SrcName,FileTime);
Assign(FrF,SrcName);
Reset(FrF,1);
FromFileSize := FileSize(FrF);

Assign(ToF,DestName);
Rewrite(ToF,1);
TotalRead := 0;
TotalWritten := 0;
REPEAT
BlockRead (FrF, Buf, SizeOf(Buf), NumRead);
TotalRead := TotalRead + NumRead;

BlockWrite(ToF, Buf, NumRead, NumWritten);
TotalWritten := TotalWritten + NumWritten;
UNTIL (NumRead = 0) OR (NumWritten <> NumRead);
Close(FrF);
Close(ToF);
{ возвращаем true, если они равны, в противном случае возвращаем false }
CopyFile := (TotalWritten = FromFileSize);
end;

[001713]


Delphi 1

Запись и чтение из файла массива записей

Это не очень Delphi-подобно (тем не менее, работа происходит с действительно паскалевскими записями), но вы можете писать и читать записи из/в файл, используя паскалевские процедуры для работы с файлами:

type
TMyRec = record ;
Field1 : integer ;
Field2 : string ;
end ;

TMyRecArray = array [0..9] of TMyRec ;

var
MyArray : TMyRecArray ;
MyRec : TMyRec ;
RecFile : file of TMyRec ;

begin

{...здесь должен быть расположен код инициализации MyArray...}

AssignFile( RecFile, 'MYREC.FIL' ) ;
ReWrite( RecFile ) ;
for i := 0 to 9 do
begin
Write( RecFile, MyRec[i] ) ;
end ;
CloseFile( RecFile ) ;

Также, вы можете использовать Read() для чтения записи из вашего файла, и Seek() для перемещения на его конкретную запись (начиная с 0). Для получения дополнительной информации обратитесь к разделу "I/O Routines" электронной справки по Delphi.

Если вы хотите делать это с Data Aware компонентами (компонентами для работы с базами данных), вы должны создать базу данных, где база данных "records" должна отражать структуру ваших паскалевских записей, при этом необходимо создать механизмы трансляции данных из одной среды в другую. Я не готов сейчас сказать вам, как это можно сделать, но, во всяком случае, всю функциональность можно инкапсулировать в отдельном специализированном компоненте. [001721]


Письмо читателя

Как удалить директорию со всеми файлами в ней находящимися?

Своим опытом делится Олег Кулабухов:

Нужно просто удалить все файлы в ней и затем саму директорию:

procedure TForm1.Button1Click(Sender: TObject);
var
DirInfo: TSearchRec;
r : Integer;
begin
r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo);
while r = 0 do begin
if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name))
= false then
ShowMessage('Unable to delete : C:\Download\test\' +
DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
if RemoveDirectory('C:\Download\Test') = false then
ShowMessage('Unable to delete direcotry : C:\Download\test');
end;

[001779]


Письмо читателя

Как отформатировать носитель под Win32?

Своим опытом делится Олег Кулабухов:

Используем ShFormatDrive:

const SHFMT_DRV_A = 0;
const SHFMT_DRV_B = 1;

const SHFMT_ID_DEFAULT = $FFFF;

const SHFMT_OPT_QUICKFORMAT = 0;
const SHFMT_OPT_FULLFORMAT = 1;
const SHFMT_OPT_SYSONLY = 2;

const SHFMT_ERROR = -1;
const SHFMT_CANCEL = -2;
const SHFMT_NOFORMAT = -3;

function SHFormatDrive(hWnd : HWND;
Drive : Word;
fmtID : Word;
Options : Word) : Longint
stdcall; external 'Shell32.dll' name 'SHFormatDrive';

procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes : longint;
begin
try
FmtRes:= ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR : ShowMessage('Error formatting the drive');
SHFMT_CANCEL :
ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT : ShowMessage('No Format')
else
ShowMessage('Disk has been formatted');
end;
except
end;

end;

[001831]


Письмо читателя

Как сбросить на диск кэшированную информацию о бинарном файле?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject);
var
f : file;
i : integer;
begin
i := 10;
AssignFile(f, 'C:\DownLoad\Test.Bin');
ReWrite(f, 1);
BlockWrite(f, i, sizeof(i));
FlushFileBuffers(TFileRec(f).Handle);
CloseFile(f);
end;

[001853]


Как узнать доступные сетевые pесуpсы?

Nomadic советует:

Вот пример:

type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;

Procedure EnumResources(LpNR:PNetResource);
Var
NetHandle: THandle;
BufSize: Integer;
Size: Integer;
NetResources: PNetResourceArray;
Count: Integer;
NetResult:Integer;
I: Integer;
NewItem:TListItem;
Begin
If WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
// RESOURCETYPE_ANY - все ресурсы
// RESOURCETYPE_DISK - диски
// RESOURCETYPE_PRINT - принтеры
 0,
LpNR,
NetHandle) <> NO_ERROR
then Exit;
Try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
Try
while True do
begin
Count := -1;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
If NetResult = ERROR_MORE_DATA then
begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
For I := 0 to Count-1 do
Begin
With NetResources^[I] do
Begin
If RESOURCEUSAGE_CONTAINER =
(DwUsage and RESOURCEUSAGE_CONTAINER)
then
EnumResources(@NetResources^[I]);
If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
// ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
// RESOURCEDISPLAYTYPE_SERVER - компьютер
// RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
// RESOURCEDISPLAYTYPE_GENERIC - сеть
 Begin
NewItem:= Form1.ListView1.Items.Add;
NewItem.Caption:=LpRemoteName;
End;
End;
End;
End;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var
OldCursor: TCursor;
begin
OldCursor:= Screen.Cursor;
Screen.Cursor:= crHourGlass;
With ListView1.Items do
Begin
BeginUpdate;
Clear;
EnumResource(nil);
EndUpdate;
End;
Screen.Cursor:= OldCursor;
end;

Исправления

Михаил Немцов обнаружил и исправил некоторые ошибки. Его код публикуется ниже:

type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;

Procedure EnumResources(LpNR:PNetResource);
Var
NetHandle: DWORD;
BufSize: DWORD;
Size:DWORD;
NetResources: PNetResourceArray;
Count: DWORD;
NetResult:Integer;
I: Integer;
NewItem:TListItem;
Begin
If WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,0,LpNR,NetHandle) <> NO_ERROR
then Exit;
Try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
Try
while True do
begin
Count := 1;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
If NetResult = ERROR_MORE_DATA then
begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
For I := 0 to Count-1 do
Begin
With NetResources^[I] do
Begin
If RESOURCEUSAGE_CONTAINER =(DwUsage and RESOURCEUSAGE_CONTAINER) then
EnumResources(@NetResources^[I]);
If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
// ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
// RESOURCEDISPLAYTYPE_SERVER - компьютер
// RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
// RESOURCEDISPLAYTYPE_GENERIC - сеть
Begin
NewItem:= Form1.ListView1.Items.Add;
NewItem.Caption:=LpRemoteName;
End;
End;
End;
End;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var
OldCursor: TCursor;
begin
OldCursor:= Screen.Cursor;
Screen.Cursor:= crHourGlass;
With ListView1.Items do
Begin
BeginUpdate;
Clear;
EnumResources(nil);
EndUpdate;
End;
Screen.Cursor:= OldCursor;
end;

end.

[001120]


Как узнать кто висит на моей (или не моей) машине

Nomadic приводит сиплюсплюсный код:

#define STRICT
#include
#include
#include
#include

void UserEnum()
{
    BOOL keepGoing = TRUE ;
    DWORD entriesRead, totalEntries ;
    USER_INFO_2 * pInfo = NULL ;
    DWORD resumeHandle = 0 ; // must be 0 to start with
    char nameBuf[ UNLEN + 1 ] ; // constants defined in LMCONS.H
    char commentBuf[ MAXCOMMENTSZ + 1 ] ;
    WCHAR serverName[ 100 ] ;
    lstrcpyW( serverName, L"\\\\PDC" ) ; //L"" ) ;
    while ( keepGoing )
    {
        NET_API_STATUS ret = NetUserEnum(
            serverName, //NULL,
            2,
   0, //FILTER_NORMAL_ACCOUNT,
            (LPBYTE *)&pInfo, // Important:  ADDRESS of POINTER
            sizeof( USER_INFO_2 ) * 100, // requested buffer size; it may not
actually allocate this much
            &entriesRead,
            &totalEntries,
            &resumeHandle ) ;

        keepGoing = ( ret == ERROR_MORE_DATA ) ;

        if ( ret == 0 || ret == ERROR_MORE_DATA )
        {
            DWORD i ;
            for ( i = 0 ; i < entriesRead ; i++ )
            {
                //  Note that strings in the INFO structures
                //  will ALWAYS be Unicode, regardless of
                //  your settings!  Even though they're declared
                //  as LPTSTR, they're always LPWSTR.
                //  I'm compiling for non-Unicode, so I
                //  convert them to ANSI strings...
                //  Check for NULL pointers in the INFO structure
                LPWSTR pName = (LPWSTR)pInfo[ i ].usri2_name ;
                LPWSTR pComm = (LPWSTR)pInfo[ i ].usri2_comment ;
                if ( pName == NULL )
                {
                    lstrcpy( nameBuf, "(no name!)" ) ;
                }
                else if ( lstrlenW( pName ) == 0 )
                {
                    lstrcpy( nameBuf, "(empty name!)" ) ;
                }
                else
                {
                    WideCharToMultiByte( CP_ACP, 0,
                        pName, -1,
                        nameBuf, UNLEN,
                        NULL, NULL ) ;
                }
                if ( pComm == NULL )
                {
                    lstrcpy( commentBuf, "(no comment!)" ) ;
                }
                else if ( lstrlenW( pComm ) == 0 )
                {
                    lstrcpy( commentBuf, "(empty comment!)" ) ;
                }
                else
                {
                    WideCharToMultiByte( CP_ACP, 0,
                        pComm, -1,
                        commentBuf, MAXCOMMENTSZ,
                        NULL, NULL ) ;
                }
                cout << nameBuf << ":  " << commentBuf << endl ;
            }
        }
        else
        {
            cout << "NetUserEnum error " << ret << endl ;
        }

        if ( pInfo )
        {
            NetApiBufferFree( pInfo ) ;
            pInfo = NULL ;
        }
    }
}
//****************************************************************************/
/
[001578]


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

Nomadic приводит сиплюсплюсный код:

NET_API_STATUS UserAdd(LPSTR username)
{

// некоторые используемые функции описаны в других QA

USER_INFO_2   user_info;

char compname[256];
wchar_t wcompname[256];
DWORD parm_err=0;
LSA_HANDLE PolicyHandle;

LPTSTR lpszSystemInfo;    // ptr. to system info. string
DWORD cchBuff = 256;      // size of comp. or user name
TCHAR tchBuffer2[256];    // buffer for concat'd. str.
WCHAR wGroupNameAdd[20]=L"Administrators";
    lpszSystemInfo = tchBuffer2;
    ZeroMemory(&user_info,sizeof(user_info));

    GetComputerName(lpszSystemInfo, &cchBuff);
    strcpy(compname,"\\\\");
    strcat(compname,lpszSystemInfo);

    mbstowcs( wcompname, compname, strlen(compname)+1 );
    mbstowcs(user_info.usri2_name,username, strlen(username)+1 );

 //-------создаем юзера------------//

        user_info.usri2_password = L"";
        user_info.usri2_priv = USER_PRIV_USER;
        user_info.usri2_flags =
UF_SCRIPT|UF_PASSWD_CANT_CHANGE|UF_DONT_EXPIRE_PASSWD|UF_NORMAL_ACCOUNT;
        user_info.usri2_acct_expires=TIMEQ_FOREVER;

 NetUserAdd(wcompname,// PDC name
       2L,                   // level
       (LPBYTE)&user_info,   // input buffer
       &parm_err );          // parameter in error

 GetAccountSid(
            NULL,       // default lookup logic
            username,    // account to obtain SID
            &pSid       // buffer to allocate to contain resultant SID
            );

 NetLocalGroupAddMember(0,wGroupNameAdd,pSid);

 //---------даем ему кое-какие права-----------//

OpenPolicy(
     wcompname,           // target machine
     POLICY_ALL_ACCESS,   //POLICY_CREATE_ACCOUNT | POLICY_LOOKUP_NAMES,
     &PolicyHandle        // resultant policy handle
      );

SetPrivilegeOnAccount(
                    PolicyHandle,           // policy handle
                    pSid,                   // SID to grant privilege
                    L"SeInteractiveLogonRight", // Unicode privilege
                    TRUE                    // enable the privilege
                    );

SetPrivilegeOnAccount(
                    PolicyHandle,           // policy handle
                    pSid,                   // SID to grant privilege
                    L"SeNetworkLogonRight", // Unicode privilege
                    TRUE                    // enable the privilege
                    );

LsaClose(PolicyHandle);

return 0;
}
//***************************************************************************//
[001580]


Как узнать ip адрес(а) машины (в текстовом виде)?

Nomadic приводит сиплюсплюсный код:

Кусок исходника от плугина к BackOrifice:

//---------------------------------------------------
void MachineIP(char *result)
{
      WSADATA WSAData;

      WSAStartup(MAKEWORD(1,1), &WSAData);

 char dot[6];
 int iResult;
 int i = 0;
 u_long *ppIpNO;
 u_long *pIpNO;
 HOSTENT FAR *lphostent;
 u_long ipHO;
 unsigned char binIp[4];
 int iterations = 0;

 //Get local host name and crudely validate
 char szHostName[100];
 *result = 0;

 iResult = gethostname(szHostName, sizeof(szHostName));
// printf("%d %s",iResult,szHostName);
 if ((iResult != 0) || (lstrcmp(szHostName, "")==0))
  return;

 //Lok up this host info via supplied name
 lphostent = gethostbyname(szHostName);
 if (lphostent == NULL)
  return;
 //Retreive first entry (might have multiple connects)
 do
 {
  iterations++;
  ppIpNO = (u_long *)lphostent->h_addr_list;
  if (ppIpNO+i == NULL)
   return;
  pIpNO = ((u_long *)*(ppIpNO+i));
  if (pIpNO == NULL)
   return;

 //convert back to host order, since SOCKADDR_IN expects that
  //MessageBox(NULL,"z","x",MB_OK);
  ipHO = ntohl(*pIpNO);

  binIp[0] = (BYTE)((ipHO & 0xff000000) >> 24);
  itoa(binIp[0], dot, 10);
  strcat(result,dot);
  binIp[1] = (BYTE)((ipHO & 0x00ff0000) >> 16);
  itoa(binIp[1], dot, 10);
  strcat(result, "."); strcat(result, dot);
  binIp[2] = (BYTE)((ipHO & 0x0000ff00) >> 8);
  itoa(binIp[2], dot, 10);
  strcat(result, "."); strcat(result, dot);
  binIp[3] = (BYTE)(ipHO & 0x000000ff);
  itoa(binIp[3], dot, 10);
  strcat(result,"."); strcat(result, dot);
  strcat(result,"\r\n");
  i++;
 } while ((pIpNO != NULL) && (iterations < 6));
 WSACleanup();
      PostQuitMessage(0);
 return;
}
//***************************************************************************//
[001583]


Как подключать сетевые диски?

Nomadic отвечает:

Деpжи pабочий кусок кода из пpогpаммы "мэйлеpа" сетевой FIDO станции:

var nw:TNetResource;

...

nw.dwType:=RESOURCETYPE_DISK;
nw.lpLocalName:=nil;
nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL');
nw.lpProvider:=nil;
if MailServer.Password<>'' then
Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0)
else
Err:=WNetAddConnection2(nw,nil,nil,0);
If Err=NO_ERROR then
begin
...
end;

MailServer.RemoteName и Password -- имя удаленного компа в сети и паpоль доступа к pесуpсу соответвенно.

ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'. если хочешь подключить сетевой pесуpс как локальный диск -- меняй nw.lpLocalName.

pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2. [001589]


Как по IP адресу получить HostName (и обратно)

Nomadic отвечает:

Хм... А ты увеpен, что пытался найти эту функцию? Ты, навеpно, будешь очень удивлен (так уж повелось в этой эхе), но это gethostbyaddr, а если в Winsock2, то можно еще WSAAddressToString Скачиваешь с microsoft или с intel WinSock2 SDK и документацию (она отдельно), там все есть.

Мне лень сейчас вспоминать и pазбиpаться, вот тебе кусочек, в котоpом этим функции используются (не пpетендую на абсолютную истину, но с IP pаботает):

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
ptr : PChar;
pHE : PHostEnt;
addr : TSockAddr;
buf : Array [0..AddressStrMaxLen-1] of Char;
begin
if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
len := SizeOf(TSockAddr);
if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
case addr.sin_family of
AF_INET: // TCP/IP
begin
pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
FPeerNodeName := pHE^.h_name;
if FNet.NodeByName(FPeerNodeName)=nil then
begin
ptr := StrScan(pHE^.h_name,'.');
if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
end;
end;
else
len := AddressStrMaxLen;
if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
ptr := StrRScan(buf,':');
if ptr<>nil then len := ptr-buf;
FPeerNodeName := Copy(buf,1,len);
end;
Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}

[001601]


Как работать с поименованными каналами под W'95/NT в сети?

Nomadic отвечает:

сервер :

StrPCopy(buff,Edit1.Text);
fPipeHandle:=CreateNamedPipe(buff,
Pipe_Access_Duplex or File_Flag_Overlapped,
Pipe_Type_Message or Pipe_ReadMode_Byte or Pipe_Wait,
5, $400, $400, 235, nil);

клиент :

StrPCopy(buff,Edit1.Text);
fFileHandle:=CreateFile(buff,
Generic_Read or Generic_Write,
File_Share_Read or File_Share_Write,
nil,
Open_Existing,
File_Attribute_Normal or File_Flag_Overlapped or Security_Anonymous,
0);
if fFileHandle <> Invalid_Handle_Value then begin ...

[001626]


Как очистить коpзинy?

Nomadic пишет:

Есть функция SHEmptyRecycleBin (в shell32.dll), но она не документирована (по крайней мере в win32.hlp ее нет). [001673]


Как из программы выявить версию Windows, на кого зарегистрирована и т.п.?

Nomadic пишет:

Вот тебе кyсочек Windows Registry, pазбиpайся:

=== Cut here! [a.reg] ===
REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion]
"InstallType"=hex:03,00
"SetupFlags"=hex:08,01,00,00
"DevicePath"="C:\\WINDOWS\\INF"
"ProductType"="9"
"RegisteredOwner"="Jacky Shikerya"
"RegisteredOrganization"="SigmaЩ Soft. Universal ltd.й"
"ProductId"="12095-OEM-0004226-12233"
"LicensingInfo"=""
"SubVersionNumber"=" B"
"InventoryPath"="C:\\WINDOWS\\SYSTEM\\PRODINV.DLL"
"ProgramFilesDir"="C:\\Program Files"
"CommonFilesDir"="C:\\Program Files\\Common Files"
"MediaPath"="C:\\WINDOWS\\media"
"ConfigPath"="C:\\WINDOWS\\config"
"SystemRoot"="C:\\WINDOWS"
"OldWinDir"=""
"ProductName"="Microsoft Windows 95"
"FirstInstallDateTime"=hex:81,73,b0,22
"Version"="Windows 95"
"VersionNumber"="4.00.1111"
"BootCount"="3"
"OtherDevicePath"="C:\\WINDOWS\\INF\\OTHER"
=== And cut Here!(or there?!) [a.reg] ===
В uses пpописываешь модуль Registry и дальше так:

var
R:TRegistry;
No:String;
begin
R:=TRegistry.Create;
R.RootKey:=HKEY_LOCAL_MACHINE;
R.OpenKey('....', False) {если false то пытается откpыть не создавая}
No:=R.ReadString('VersionNumber');
if No=..... then ...... else ......
end;

Выше был приведён кусочек из Windows 95/98 Registry. В Windows NT эта ветвь находится в разделе

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion]
Кроме того, обязательно посмотрите на список функций WinAPI, имена которых начинаются с Get.... Например, GetComputerName, GetVersionEx, GetSystemInfo, SystemParametersInfo. [001218]


Как получить имя программы, с которой ассоциировано то или иное расширение?

Олег Кулабухов приводит следующий код:

uses
{$IFDEF WIN32}
Registry; {We will get it from the registry}
{$ELSE}
IniFiles; {We will get it from the win.ini file}
{$ENDIF}

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

function GetProgramAssociation (Ext : string) : string;
var
{$IFDEF WIN32}
reg: TRegistry;
s : string;
{$ELSE}
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
{$ENDIF}
begin
{$IFDEF WIN32}
s := '';
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
if reg.OpenKey('.' + ext + '\shell\open\command',
false) <> false then begin
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end else begin
{perhaps thier is a system file pointer}
if reg.OpenKey('.' + ext,
false) <> false then begin
s := reg.ReadString('');
reg.CloseKey;
if s <> '' then begin
{A system file pointer was found}
if reg.OpenKey(s + '\shell\open\command',
false) <> false then
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end;
end;
end;
{Delete any command line, quotes and spaces}
 if Pos('%', s) > 0 then
Delete(s, Pos('%', s), length(s));
if ((length(s) > 0) and
(s[1] = '"')) then
Delete(s, 1, 1);
if ((length(s) > 0) and
(s[length(s)] = '"')) then
Delete(s, Length(s), 1);
while ((length(s) > 0) and
((s[length(s)] = #32) or
(s[length(s)] = '"'))) do
Delete(s, Length(s), 1);
{$ELSE}
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('Extensions',
ext,
'');
WinIni.Free;
{Delete any command line}
if Pos(' ^', s) > 0 then
Delete(s, Pos(' ^', s), length(s));
{$ENDIF}
result := s;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetProgramAssociation('gif'));
end;

[001788]


Удобная загрузка местоположения формы

Virtualik советует:

Если вы храните параметры местоположения(Top, Left, Width, Height) формы в реестре, то чтобы не загружать данные из нескольких ключей вы можете их записать в один, и из одного же прочитать ;)

По сути, данные записывается в виде record'а. А как это примерно может выглядеть смотрите в примере.

var
Ini: TRegIniFile;

....

procedure TForm1.FormCreate(Sender: TObject);
var
Rct: TRect;
begin
Ini:= TRegIniFile.Create('<Здесь вы пишете путь к вашим настройкам в
реестре>');
// Если есть данные --> загружаем их
if Ini.ReadBinaryData('FormPosition', Rct, SizeOf(TRect))>0 then BoundsRect :=
Rct;
...
end;

procedure TReply.FormDestroy(Sender: TObject);
var
Rct: TRect;
begin
// Сохранение данных на выходе
...
Rct := BoundsRect;
Ini.WriteBinaryData('MsgPos', Rct, SizeOf(TRect));
Ini.Free;
end;

[001814]


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

Своим опытом делится Олег Кулабухов:

Необходимо послать всем окнам сообщение WM_WININICHANGE с указанием полного адреса измененного адреса ключа.

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST,
WM_WININICHANGE,
0,
LongInt(PChar('RegistrySection')));
end;

[001828]


Как сделать так, чтобы приложение загружалось при каждой загрузке Windows?

Своим опытом делится Олег Кулабухов:

В данном случае просто следить за соответствующими записями в реестре. Вот пример для Win16 и Win32:

uses
Registry, {For Win32}
IniFiles; {For Win16}

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

{For Win32}
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',
false);
reg.WriteString('My App', Application.ExeName);
reg.CloseKey;
reg.free;
end;

{For Win16}
procedure TForm1.Button2Click(Sender: TObject);
var
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows',
'run',
'');
if s = '' then
s := Application.ExeName else
s := s + ';' + Application.ExeName;
WinIni.WriteString('windows',
'run',
s);
WinIni.Free;
end;

[001850]


Как узнать, откуда инсталлировалась Windows?

Своим опытом делится Олег Кулабухов:

Очень просто. Эти данные записаны в реестре, нудно всего лишь считать их оттуда:

procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',
false);
ShowMessage(reg.ReadString('SourcePath'));
reg.CloseKey;
reg.free;
end;

[001858]


Создание ярлыков I

VRSLazy@mail.ru пишет:

Может ещё так можно ярлыки делать?

uses ... ShlObj, ComObj, ActiveX, shellapi, ComCtrls, ... // не помню какая из них нужна, вообще наити можно поиском в *.pas в каталоге
// disk:\Program Files\Borland\Delphi5\Source
procedure SetShortCut(path, cmd, icon, wd, name, arg : String);
var ShellObject:IUnknown;
LinkFile:IPersistFile;
ShellLink:IShellLink;
begin
Try
CoInitialize(nil);
ShellObject:=CreateComObject(CLSID_ShellLink);
LinkFile:=ShellObject as IPersistFile;
ShellLink:=ShellObject as IShellLink;  // RTFM - интерфейсу IShellLink, там всё описано
ShellLink.SetPath(@cmd[1]);
ShellLink.SetWorkingDirectory(@wd[1]);
ShellLink.SetIconLocation(@icon[1],0); // вместо 0 можно указать номер иконки если их там много...
ShellLink.SetDescription(@name[1]);
ShellLink.SetArguments(@arg[1]);
LinkFile.Save(PWChar(WideString(path)),true);
finally
ShellObject:=Unassigned;
CoUninitialize;
end;
end;

[001272]


Создание ярлыков II

Свою версию предлагает Nomadic:

function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
IPersistFile;
var
MyObject  : IUnknown;
MySLink   : IShellLink;
MyPFile   : IPersistFile;
WideFile  : WideString;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetPath(PChar(CmdLine));
SetArguments(PChar(Args));
SetWorkingDirectory(PChar(WorkDir));
end;
WideFile := LinkFile;
MyPFile.Save(PWChar(WideFile), False);
Result := MyPFile;
end;

procedure CreateShortcuts;
var Directory, ExecDir: String;
MyReg: TRegIniFile;
begin
MyReg := TRegIniFile.Create(
'Software\MicroSoft\Windows\CurrentVersion\Explorer');

ExecDir := ExtractFilePath(ParamStr(0));
Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
ProgramMenu;
CreateDir(Directory);
MyReg.Free;

CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
Directory + '\Demonstration.lnk');
CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
Directory + '\Installation notes.lnk');
CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
Directory + '\Install Intel Video Interactive.lnk');
end;

Разберешься?

Гм. Вообще правильнее в процедуре CreateShortcuts пользовать Win32API::GetSpecialFolderLocation с нужным параметром (CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола"). [001599]


Создание ярлыков III

Свою версию предлагает Nomadic:

........................................................
uses ShlObj, ComObj, ActiveX;

procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var
IObject: IUnknown;
SLink: IShellLink;
PFile: IPersistFile;
begin
IObject := CreateComObject(CLSID_ShellLink);
SLink := IObject as IShellLink;
PFile := IObject as IPersistFile;
with SLink do begin
SetArguments(PChar(Param));
SetDescription(PChar(Desc));
SetPath(PChar(PathObj));
end;
PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;
........................................................

[001653]


Как можно запустить *.lnk?

Свою версию предлагает Олег Кулабухов:

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(0,
nil,
'C:\WINDOWS\START MENU\DELPHI\Delphi3.lnk',
nil,
nil,
SW_SHOWNORMAL);

[001790]


Вызов процедуры в другом потоке

Nomadic коротко отвечает:

CreateThread(nil,0,@MyProcedure,0,0,nil);

[001735]


`Устойчивые` всплывающие подсказки

На TabbedNotebook у меня есть множество компонентов TEdit. Я изменяю цвет компонентов TEdit на желтый и назначаю свойству Hint компонента строчку предупреждения, если поле редактирования содержит неверные данные.

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

Я не знаю как изменить поведение всплывающей подсказки, заданное по умолчанию. Я знаю что это возможно, но кто мне подскажет как?

Ниже приведен модуль, содержащий новый тип hintwindow, TFocusHintWindow. Когда вы "просите" TFocusHintWindow появиться, он появляется ниже элемента управления, имеющего фокус. Для показа и скрытия достаточно следующих команд:

FocusHintWindow.Showing := True;
FocusHintWindow.Showing := False;

Пример того, как это можно использовать, содержится в комментариях к модулю. Это просто.

unit FHintWin;

{ -----------------------------------------------------------
TFocusHintWindow --

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

unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, FHintWin;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FocusHintWindow: TFocusHintWindow;
procedure AppIdle( Sender: TObject; var Done: Boolean );
procedure AppShowHint( var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo );
end;

implementation

procedure TForm1.FormCreate( Sender: TObject );
begin
Application.OnIdle := AppIdle;
Application.OnShowHint := AppShowHint;
FocusHintWindow := TFocusHintWindow.Create( Self );
end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
FocusHintWindow.Showing := Screen.ActiveControl is TEdit;
end;

procedure TForm1.AppShowHint( var HintStr: string;
var CanShow: Boolean; var HintInfo: THintInfo );
begin
CanShow := not FocusHintWindow.Showing;
end;

end.
----------------------------------------------------------- }
interface

uses SysUtils, WinTypes, WinProcs, Classes, Controls, Forms;

type
TFocusHintWindow = class( THintWindow )
private
FShowing: Boolean;
HintControl: TControl;
protected
procedure SetShowing( Value: Boolean );
function CalcHintRect( Hint: string ): TRect;
procedure Appear;
procedure Disappear;
public
property Showing: Boolean read FShowing write SetShowing;
end;

implementation

function TFocusHintWindow.CalcHintRect( Hint: string ): TRect;
var
Buffer: array[ Byte ] of Char;
begin
Result := Bounds( 0, 0, Screen.Width, 0 );
DrawText( Canvas.Handle, StrPCopy( Buffer, Hint ), -1, Result,
DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX );

with HintControl, ClientOrigin do
OffsetRect( Result, X, Y + Height + 6 );
Inc( Result.Right, 6 );
Inc( Result.Bottom, 2 );
end;

procedure TFocusHintWindow.Appear;
var
Hint: string;
HintRect: TRect;
begin
if ( Screen.ActiveControl = HintControl ) then Exit;

HintControl := Screen.ActiveControl;
Hint := GetShortHint( HintControl.Hint );
HintRect := CalcHintRect( Hint );
ActivateHint( HintRect, Hint );
FShowing := True;
end;

procedure TFocusHintWindow.Disappear;
begin
HintControl := nil;
ShowWindow( Handle, SW_HIDE );
FShowing := False;
end;

procedure TFocusHintWindow.SetShowing( Value: Boolean );
begin
if Value then Appear else Disappear;
end;

end.

- Ed Jordan [001001]


Вызов 16-разрядного кода из 32-разрядного

Andrew Pastushenko пишет:

Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".

{ GetFeeSystemResources routine for 32-bit Delphi.
Works only under Windows 9x }

unit SysRes32;

interface

const
//Constants whitch specifies the type of resource to be checked

GFSR_SYSTEMRESOURCES = $0000;
GFSR_GDIRESOURCES    = $0001;
GFSR_USERRESOURCES   = $0002;

// 32-bit function exported from this unit

function GetFeeSystemResources(SysResource: Word):Word;

implementation

uses
SysUtils, Windows;

type

//Procedural variable for testing for a nil
TGetFSR = function(ResType: Word): Word; stdcall;

//Declare our class exeptions
EThunkError = class(Exception);
EFOpenError = class(Exception);

var
User16Handle : THandle = 0;
GetFSR       : TGetFSR = nil;

//Prototypes for some undocumented API

function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall;
external kernel32 index 35;

function FreeLibrary16(LibModule: THandle): THandle; stdcall;
external kernel32 index 36;

function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall;
external kernel32 index 37;

procedure QT_Thunk; cdecl;
external 'kernel32.dll' name 'QT_Thunk';

{$StackFrames On}

function GetFeeSystemResources(SysResource: Word):Word;
var
EatStackSpace: String[$3C];
begin
// Ensure buffer isn't optimised away
EatStackSpace := '';
@GetFSR:=GetProcAddress16(User16Handle,'GETFREESYSTEMRESOURCES');
if  Assigned(GetFSR) then  //Test result for nil
asm
//Manually push onto the stack type of resource to be checked first
push  SysResource
//Load routine address into EDX
mov   edx, [GetFSR]
//Call routine
call  QT_Thunk
//Assign result to the function
mov   @Result, ax
end
else raise EFOpenError.Create('GetProcAddress16 failed!');
end;

initialization

//Check Platform for Windows 9x
if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then
raise EThunkError.Create('Flat thunks only supported under Windows 9x');

//Load 16-bit DLL (USER.EXE)
User16Handle:= LoadLibrary16(PChar('User.exe'));
if User16Handle < 32 then
raise EFOpenError.Create('LoadLibrary16 failed!');

finalization

//Release 16-bit DLL when done
if User16Handle <> 0 then
FreeLibrary16(User16Handle);

end.

[001068]


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

Nomadic пишет:

// Routine: check if the user has administrator provileges
// Was converted from C source by Akzhan Abdulin. Not properly tested.
type
PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator (): Boolean;
var
SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
psidAdmin: PSID;
ptg: PTOKEN_GROUPS = nil;
htkThread: Integer; { HANDLE }
cbTokenGroups: Longint; { DWORD }
iGroup: Longint; { DWORD }
bAdmin: Boolean;

begin
Result := false;
if not OpenThreadToken(GetCurrentThread(),      // get security token
TOKEN_QUERY,
FALSE,
htkThread) then
if GetLastError() = ERROR_NO_TOKEN then
begin
if not OpenProcessToken(GetCurrentProcess(),
TOKEN_QUERY,
htkThread) then
Exit;
end
else
Exit;
if GetTokenInformation(htkThread,            // get #of groups
TokenGroups,
nil,
0,
cbTokenGroups) then
Exit;
if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
Exit;
ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) );
if not Assigned(ptg) then
Exit;
if not GetTokenInformation(htkThread,           // get groups
TokenGroups,
ptg,
cbTokenGroups,
cbTokenGroups) then
Exit;
if not AllocateAndInitializeSid(SystemSidAuthority,
2,
SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0,
psidAdmin) then
Exit;
iGroup := 0;
while iGroup < ptg^.GroupCount do // check administrator group
begin
if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
begin
Result := TRUE;
break;
end;
Inc( iGroup );
end;
FreeSid(psidAdmin);
end;

Два метода в одном флаконе:

#include
#include
#include
#pragma hdrstop

#pragma comment( lib, "netapi32.lib" )

// My thanks to Jerry Coffin (jcoffin@taeus.com)
// for this much simpler method.
bool jerry_coffin_method()
{
 bool result;
 DWORD rc;
 wchar_t user_name[256];
 USER_INFO_1 *info;
 DWORD size = sizeof( user_name );

 GetUserNameW( user_name, &size);

 rc = NetUserGetInfo( NULL, user_name, 1, (byte **) &info );
 if ( rc != NERR_Success )
  return false;

 result = info->usri1_priv == USER_PRIV_ADMIN;

 NetApiBufferFree( info );
 return result;
}

bool look_at_token_method()
{
 int found;
 DWORD i, l;
 HANDLE hTok;
 PSID pAdminSid;
 SID_IDENTIFIER_AUTHORITY ntAuth = SECURITY_NT_AUTHORITY;

 byte rawGroupList[4096];
 TOKEN_GROUPS& groupList = *( (TOKEN_GROUPS *) rawGroupList );

 if ( ! OpenThreadToken( GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok ) )
 {
  printf( "Cannot open thread token, trying process token [%lu].\n",
   GetLastError() );
  if ( ! OpenProcessToken( GetCurrentProcess(), TOKEN_QUERY, &hTok ) )
  {
   printf( "Cannot open process token, quitting [%lu].\n",
    GetLastError() );
   return 1;
  }
 }

 // normally, I should get the size of the group list first, but ...
 l = sizeof rawGroupList;
 if ( ! GetTokenInformation( hTok, TokenGroups, &groupList, l, &l ) )
 {
  printf( "Cannot get group list from token [%lu].\n",
   GetLastError() );
  return 1;
 }

 // here, we cobble up a SID for the Administrators group, to compare to.
 if ( ! AllocateAndInitializeSid( &ntAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
  DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid ) )
 {
  printf( "Cannot create SID for Administrators [%lu].\n",
   GetLastError() );
  return 1;
 }

 // now, loop through groups in token and compare
 found = 0;
 for ( i = 0; i < groupList.GroupCount; ++ i )
 {
  if ( EqualSid( pAdminSid, groupList.Groups[i].Sid ) )
  {
   found = 1;
   break;
  }
 }

 FreeSid( pAdminSid );
 CloseHandle( hTok );
 return !!found;
}

int main()
{
 bool j, l;

 j = jerry_coffin_method();
 l = look_at_token_method();

 printf( "NetUserGetInfo(): The current user is %san Administrator.\n",
  j? "": "not " );
 printf( "Process token: The current user is %sa member of the Administrators group.\n",
  l? "": "not " );

 return 0;
}

//****************************************************************************//
[001094]


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

Как узнать язык Windows по умолчанию?

Nomadic лаконично отвечает:

GetSystemDefaultLCID
GetLocaleInfo [001104]


GetLocalUserList - возвращает список пользователей (Windows NT, Windows 2000)

Кондратюк Виталий предлагает следующий код:

unit Func;
interface

uses Sysutils, Classes, Stdctrls, Comctrls, Graphics, Windows;

////////////////////////////////////////////////////////////////////////////////
{$EXTERNALSYM NetUserEnum}
function NetUserEnum( servername    : LPWSTR;
level,
filter        : DWORD;
bufptr        : Pointer;
prefmaxlen    : DWORD;
entriesread,
totalentries,
resume_handle : LPDWORD    ) : DWORD; stdcall;
external 'NetApi32.dll' Name 'NetUserEnum';

function NetApiBufferFree( Buffer : Pointer{LPVOID} ) : DWORD; stdcall;
external 'NetApi32.dll' Name 'NetApiBufferFree';
////////////////////////////////////////////////////////////////////////////////

procedure GetLocalUserList(ulist: TStringList);

implementation

//------------------------------------------------------------------------------
// возвращает список пользователей локального хоста
//------------------------------------------------------------------------------
 procedure GetLocalUserList(ulist: TStringList);
const
NERR_SUCCESS                     =  0;
FILTER_TEMP_DUPLICATE_ACCOUNT    =  $0001;
FILTER_NORMAL_ACCOUNT            =  $0002;
FILTER_PROXY_ACCOUNT             =  $0004;
FILTER_INTERDOMAIN_TRUST_ACCOUNT =  $0008;
FILTER_WORKSTATION_TRUST_ACCOUNT =  $0010;
FILTER_SERVER_TRUST_ACCOUNT      =  $0020;

type
TUSER_INFO_10 = record
usri10_name,
usri10_comment,
usri10_usr_comment,
usri10_full_name     : PWideChar;
end;
PUSER_INFO_10 = ^TUSER_INFO_10;

var
dwERead, dwETotal, dwRes, res : DWORD;
inf  : PUSER_INFO_10;
info : Pointer;
p    : PChar;
i    : Integer;
begin
if ulist=nil then
Exit;
ulist.Clear;

info  := nil;
dwRes := 0;
res := NetUserEnum( nil,
10,
FILTER_NORMAL_ACCOUNT,
@info,
65536,
@dwERead,
@dwETotal,
@dwRes);
if (res<>NERR_SUCCESS) or (info=nil) then
Exit;
p := PChar(info);
for i:=0 to dwERead-1 do begin
inf := PUSER_INFO_10 ( p + i*SizeOf(TUSER_INFO_10) );
ulist.Add( WideCharToString( PWideChar((inf^).usri10_name) ) );
end;

NetApiBufferFree(info);
end;

end.

[001197]


Каков способ обмена информацией между приложениями Win32 - Win16?

Nomadic предлагает следующее:

Пользуйтесь сообщением WM_COPYDATA.

Для Win16 константа определена как $004A, для Win32 смотрите в WinAPI Help.

#define WM_COPYDATA 0x004A
/*
* lParam of WM_COPYDATA message points to...
*/
typedef struct tagCOPYDATASTRUCT {
DWORD dwData;
DWORD cbData;
PVOID lpData;
} COPYDATASTRUCT, *PCOPYDATASTRUCT;
[001212]


Остановка и запуск сервисов

Postmaster предлагает следующий код:

Unit1.dfm

object Form1: TForm1
Left = 192
Top = 107
Width = 264
Height = 121
Caption = 'Сервис'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 2
Top = 8
Width = 67
Height = 13
Caption = 'Имя сервиса'
end
object Button1: TButton
Left = 4
Top = 56
Width = 95
Height = 25
Caption = 'Стоп сервис'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 148
Top = 56
Width = 95
Height = 25
Caption = 'Старт сервис'
TabOrder = 1
OnClick = Button2Click
end
object Edit1: TEdit
Left = 0
Top = 24
Width = 241
Height = 21
TabOrder = 2
Text = 'Messenger'
end
end

Unit1.pas

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,Winsvc;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure StopService(ServiceName: String);
procedure Button2Click(Sender: TObject);
procedure StartService(ServiceName: String);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
StopService(Edit1.Text);
end;

procedure TForm1.StopService(ServiceName: String);
var
schService,
schSCManager: DWORD;
p: PChar;
ss: _SERVICE_STATUS;
begin
p:=nil;
schSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if schSCManager = 0 then RaiseLastWin32Error;
try
schService:=OpenService(schSCManager,PChar(ServiceName),SERVICE_ALL_ACCESS);
if schService = 0 then RaiseLastWin32Error;
try
if not ControlService(schService,SERVICE_CONTROL_STOP,SS) then  RaiseLastWin32Error;
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
StartService(Edit1.Text);
end;

procedure TForm1.StartService(ServiceName: String);
var
schService,
schSCManager: Dword;
p: PChar;
begin
p:=nil;
schSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if schSCManager = 0 then RaiseLastWin32Error;
try
schService:=OpenService(schSCManager,PChar(ServiceName),SERVICE_ALL_ACCESS);
if schService = 0 then RaiseLastWin32Error;
try
if not Winsvc.startService(schService,0,p) then RaiseLastWin32Error;
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;

end.

[001309]


Delphi 1

Прямой вызов метода Hint

function RevealHint (Control: TControl): THintWindow;
{----------------------------------------------------------------}
{ Демонстрирует всплывающую подсказку для определенного элемента }
{ управления (Control), возвращает ссылку на hint-объект,        }
{ поэтому в дальнейшем подсказка может быть спрятана вызовом     }
{ RemoveHint (смотри ниже).                                      }
{----------------------------------------------------------------}
var
ShortHint: string;
AShortHint: array[0..255] of Char;
HintPos: TPoint;
HintBox: TRect;
begin
{ Создаем окно: }
Result := THintWindow.Create(Control);

{ Получаем первую часть подсказки до '|': }
ShortHint := GetShortHint(Control.Hint);

{ Вычисляем месторасположение и размер окна подсказки }
HintPos := Control.ClientOrigin;
Inc(HintPos.Y, Control.Height + 6);    <<<< Смотри примечание ниже
HintBox := Bounds(0, 0, Screen.Width, 0);
DrawText(Result.Canvas.Handle,
StrPCopy(AShortHint, ShortHint), -1, HintBox,
DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
OffsetRect(HintBox, HintPos.X, HintPos.Y);
Inc(HintBox.Right, 6);
Inc(HintBox.Bottom, 2);

{ Теперь показываем окно: }
Result.ActivateHint(HintBox, ShortHint);
end; {RevealHint}

procedure RemoveHint (var Hint: THintWindow);
{----------------------------------------------------------------}
{ Освобождаем дескриптор окна всплывающей подсказки, выведенной  }
{ предыдущим RevealHint.                                         }
{----------------------------------------------------------------}
begin
Hint.ReleaseHandle;
Hint.Free;
Hint := nil;
end; {RemoveHint}

Строка с комментарием <<<< позиционирует подсказку ниже элемента управления. Это может быть изменено, если по какой-то причине вам необходима другая позиция окна с подсказкой. [001461]


Как использовать свои курсоры в программе? I

Nomadic предлагает следующее:

{$R CURSORS.RES}

const
crZoomIn = 1;
crZoomOut = 2;

Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');

С вашей программой должен быть слинкован файл ресурсов, содержащий соответствующие курсоры. [001524]


Как использовать свои курсоры в программе? II

С помощью программы Image Editor упакуйте курсор в RES-файл. В следующем примере подразумевается, что вы сохранили курсор в RES-файле как "cursor_1", и записали RES-файл с именем MYFILE.RES.

{$R c:\programs\delphi\MyFile.res}   { Это ваш RES-файл }

const PutTheCursorHere_Dude = 1;     { произвольное положительное число }

procedure stuff;
begin
screen.cursors[PutTheCursorHere_Dude] := LoadCursor(hInstance,
PChar('cursor_1'));
screen.cursor := PutTheCursorHere_Dude;
end;

[001537]


Как изменить внешний вид хинтов (всплывающих подсказок)?

Nomadic предлагает следующее:

  1. Создаем свой класс - потомок от THintWindow

    type
    TCustomHint = class (THintWindow)
    public
    constructor Create(AOwner: TComponent); override;
    end;

    Пpимечание 1. Этот способ не позволит изменить цвет шpифта - для этого пpидется пеpекpывать метод Paint;

    Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать Hint в фоpме облачка.

    Пpимечание 3. Для изменения цвета фона F1 TApplication.OnShowHint, HintInfo.

  2. Меняем фонт:

    constructor TCustomHint.Create(AOwner: TComponent);
    begin
    inherited Create(AOwner);
    with Canvas.Font do               // Именно так, а не пpосто Font!
    begin
    Name := 'Times New Roman Cyr';
    Style := [fsBold, fsItalic];
    Size := 40;
    end;
    end;

  3. Устанавливаем новый хинт

    procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой
    begin                                         // обpаботчик
    HintWindowClass := TMyHint;      // Устанавливаем глобальную пеpеменную
    Application.ShowHint := false;   // Application.FHintWindow.Free
    Application.ShowHint := true;    // Application.FHintWindow.Create
    end;

Литеpатуpа:
  1. <...>\Source\VCL\Forms.pas (TApplication).
  2. <...>\Source\VCL\Controls.pas (THintWindow).
  3. Delphi Help (OnShowHint, THintInfo). [001622]


Как определить из под какой операционной системы запущена программа?

Nomadic предлагает следующий код:

If (GetVersion() and $80000000)<>0 then
//  ...'Windows 95/98'...
else
//   ... 'Windows NT'...
end;

[001663]


Как заставить появляться хинт, когда я захочy?

Nomadic предлагает следующий код:

{Появление}
IF h<>nil H.ReleaseHandle; {если чей-то хинт yже был, то его погасить}
H:=THintWindow.Create(Окно-владелец хинта);
H.ActivateHint(H.CalcHintRect(...),'hint hint nint');
....
{UnПоявление :) - это возможно пpидется повесить на таймеp, котоpый бyдет
обнyляться пpи каждом новом появлении хинта}
IF h<>nil H.ReleaseHandle;

По-дpyгомy задача тоже pешаема, но очень плохо. (см исходник объекта TApplication, он как pаз сабжами заведyет. [001667]


Как из своего пpиложения опpеделить загpузку pесуpсов GDI и USER?

Nomadic предлагает следующий код:

{$APPTYPE CONSOLE}
// индикатоp pесуpсов
program res;
function MyGetFreeSystemResources32(Id:integer):integer;
stdcall; external 'rsrc32' name '_MyGetFreeSystemResources32@4';
const
rSystem=0;
rGDI=1;
rUSER=2;
begin
writeln('free resources');
writeln('System:',MyGetFreeSystemResources32(rSystem),'%');
writeln('GDI:',MyGetFreeSystemResources32(rGDI),'%');
writeln('USER:',MyGetFreeSystemResources32(rUSER),'%');
end.

[001696]


Как получить список процессов?

Nomadic предлагает следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
handler:thandle;
data:TProcessEntry32;
function return_name:string;
var
i:byte;
names:string;
begin
names:='';
i:=0;
while data.szExeFile[i] <> '' do
begin
names:=names+data.szExeFile[i];
inc(i);
end;
return_name:=names;
end;

begin
handler:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
if process32first(handler,data) then begin
listbox1.Items.add(return_name);
while process32next(handler,data) do
listbox1.Items.add(return_name);
end
else
showmessage('Ошибка получения информации :)');
end;

А запускать например так:

procedure TForm1.Label3Click(Sender: TObject);
begin
shellexecute(handle,'open','mailto:maxrus@mail.ru',nil,nil,0)
end;
end.

[001711]


Как повесить винду?

Nomadic предлагает следующий код:

uses TLHelp32;

const
PROCESS_TERMINATE=$0001;
var
FSnapshotHandle:THandle;
FProcessEntry32:TProcessEntry32;
ContinueLoop:BOOL;
begin
FSnapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
ContinueLoop:=Process32First(FSnapshotHandle,FProcessEntry32);
while integer(ContinueLoop)<>0 do
begin
if LowerCase(ExtractFileName(
(FProcessEntry32.szExeFile)))='kernel32.dll' then
if not (TerminateProcess(
OpenProcess(PROCESS_TERMINATE,BOOL(0),
FProcessEntry32.th32ProcessID),0)) then
MessageBoxEx(Application.Handle,
'Can`t kill windows kernel...',
'Warning',MB_ICONWarning+MB_OK,$0419);
ContinueLoop:=Process32Next(FSnapshotHandle,FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;

[001724]


Фyнкция опpеделения Win2K?

Nomadic предлагает:
GetVersionEx

dwPlatformId = VER_PLATFORM_WIN32_NT
dwMajorVersion = 5
[001732]


Проблема всплывающих подсказок в дочерних MDI-формах

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

Объявите следующую процедуру в классе вашей главной формы:

private
{============================================================}
{ Процедура, вызываемая приложением всякий раз, когда        }
{ приложение хотело бы показать всплывающую подсказку.       }
{ Добавляет хинт на панель статуса.                          }
{============================================================}
procedure
ShowHint
(
Sender : TObject
);

затем в процедуре главной формы .create добавьте следующую строку:

Application.OnHint := ShowHint;{ Отображает хинт на статусной панели}

Теперь приведем код функции ShowHint, принадлежащей главной форме:

{================================================================}
{ Обновляем pnlStatusText.Caption с текстом всплывающей подсказки}
{ элемента управления, над которым находится курсор мыши.        }
{================================================================}
 procedure
TMainFrame.ShowHint
(
Sender : TObject  {Объект, вызывающий данную процедуру}
);
begin
pnlStatusText.Caption := Application.Hint;
end; { TMainFrame.ShowHint }

Это должно работать. Вам нужно будет только задать текст подсказок для элементов управления во всех окнах, включая главное. Устанавливая свойство показа хинтов в false или true, вы тем самым указываете способ показа хинтов: обычным способом в виде всплывающих окошек, или совместно с показом в строке состояния. [001765]


Как получить список доступных носителей?

Олегом Кулабухов предлагает следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
ld : DWORD;
i : integer;
begin
ld := GetLogicalDrives;
for i := 0 to 25 do begin
if (ld and (1 shl i)) <> 0 then
Memo1.Lines.Add(Char(Ord('A') + i) + ':\');
end;
end;

[001784]


Функция определения версии ОС

Василенко Игорь предлагает следующий код:

const
{ operating system constants }
cOsUnknown  = -1;
cOsWin95    =  0;
cOsWin98    =  1;
cOsWin98SE  =  2;
cOsWinME    =  3;
cOsWinNT    =  4;
cOsWin2000  =  5;
cOsWhistler =  6;

function GetOperatingSystem : integer;
var
osVerInfo    : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := cOsUnknown;
{ set operating system type flag }
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
begin
if majorVer <= 4 then
result := cOsWinNT
else if (majorVer = 5) AND (minorVer= 0) then
result := cOsWin2000
else if (majorVer = 5) AND (minorVer = 1) then
result := cOsWhistler
else
result := cOsUnknown;
end;
VER_PLATFORM_WIN32_WINDOWS :  { Windows 9x/ME }
begin
if (majorVer = 4) AND (minorVer = 0) then
result := cOsWin95
else if (majorVer = 4) AND (minorVer = 10) then
begin
if osVerInfo.szCSDVersion[1] = 'A' then
result := cOsWin98SE
else
result := cOsWin98;
end
else if (majorVer = 4) AND (minorVer = 90) then
result := cOsWinME
else
result := cOsUnknown;
end;
else
result := cOsUnknown;
end;
end
else
result := cOsUnknown;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetOperatingSystem));
end;

[001792]


Можно ли сменить шрифт всплывающих подсказок?

Олег Кулабухов приводит следующий код:

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
procedure MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
var
i : integer;
begin
for i := 0 to Application.ComponentCount - 1 do
if Application.Components[i] is THintWindow then
with THintWindow(Application.Components[i]).Canvas do begin
Font.Name := 'Arial';
Font.Size := 18;
Font.Style := [fsBold];
HintInfo.HintColor := clWhite;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := MyShowHint;
end;

[001849]


Delphi 1

Пересборка индексов с помощью TBatchMove

... вы все делаете правильно. BatchMove не может пересобирать индексы. Тем не менее, следующая процедура все же поможет вам сделать это (создать индексы заново). Задайте ей необходимые параметры (.DBF. Name, исходная и целевая таблица, Source и Target) и попробуйте ее в деле!

procedure TForm1.FormCreate(Sender: TObject);
var
x : integer  ;
begin
BatchMove1.Execute ;
Source.Open ;
Target.Exclusive := True ;
Target.Open ;
Source.IndexDefs.Update ;
for x := 0 to Source.IndexDefs.Count - 1 do
Target.AddIndex(Source.IndexDefs[x].Name,
Source.IndexDefs[x].Fields,
Source.IndexDefs[x].Options) ;
Source.Close ;
Target.Close ;
end;

[001331]


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

Nomadic отвечает:

Удобней всего, напpимеp, так -

with bmovMyBatchMove do
begin
Mode := bmCopy;
RecordCount := 1;
Execute;R Destination.Delete;
end;

Где bmovMyBatchMove - экземпляр класса TBatchMove из VCL.

Hеправда Ваша! ;)

Этот загадочный BatchMove имеет одну очень неприятную особенность (по крайней мере при работе с DBF-таблицами и в Delphi 1.0x), как-то:

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

Я эту особенность побороть не сумел, а мириться с ней в условиях нашей конторы (когда приходится бороться за место под солнцем с программистами на Clipper и FoxPro совершенно неприемлемо.

Кроме того, в предложенном выше варианте еще и запись удалять приходится...:)

Решалась же эта проблема следующим способом:

procedure CopyStruct( SrcTable, DestTable: TTable; cpyFields: array of string );
var
i: Integer;
bActive: Boolean;
SrcDatabase,DestDatabase: TDatabase;
iSrcMemSize,iDestMemSize: Integer;
pSrcFldDes: PFldDesc; CrtTableDesc: CRTblDesc;
bNeedAllFields: Boolean;
begin
SrcDatabase := Session.OpenDatabase( SrcTable.DatabaseName );
try
DestDatabase := Session.OpenDatabase( DestTable.DatabaseName );
try
bActive := SrcTable.Active;
SrcTable.FieldDefs.Update;
iSrcMemSize := SrcTable.FieldDefs.Count * SizeOf( FLDDesc );
pSrcFldDes := AllocMem( iSrcMemSize );
if pSrcFldDes = nil then
begin
raise EOutOfMemory.Create( 'Не хватает памяти!' );
end;
try
SrcTable.Open;
Check( DbiGetFieldDescs( SrcTable.Handle, pSrcFldDes ) );
SrcTable.Active := bActive;
FillChar( CrtTableDesc, SizeOf( CrtTableDesc ), 0 );
with CrtTableDesc do
begin
StrPcopy( szTblName, DestTable.TableName );
StrPcopy( szTblType, 'DBASE');
if ( Length( cpyFields[0] ) = 0 ) or ( cpyFields[0] = '*' ) then
begin bNeedAllFields := True;
SrcTable.FieldDefs.Update;
iFldCount := SrcTable.FieldDefs.Count;
end
else
begin
bNeedAllFields := False;
iFldCount := High( cpyFields ) + 1;
end;
iDestMemSize := iFldCount * Sizeof( FLDDesc );
CrtTableDesc.pFLDDesc := AllocMem( iDestMemSize );
if CrtTableDesc.pFLDDesc = nil then
begin
raise EOutOfMemory.Create( 'Не хватает памяти!' );
end;
end;
try
if bNeedAllFields then
begin
for i := 0 to CrtTableDesc.iFldCount - 1 do
begin
Move( PFieldDescList( pSrcFldDes )^[i], PFieldDescList( CrtTableDesc.pFLDDesc )^[i], SizeOf( FldDesc ) );
end;
end
else
begin
for i:=0 to CrtTableDesc.iFldCount-1 do
begin
Move( PFieldDescList( pSrcFldDes )^[SrcTable.FieldDefs.Find( cpyFields[i] ).FieldNo - 1], PFieldDescList( CrtTableDesc.pFLDDesc )^[i], SizeOf( FldDesc ) );
end;
end;
Check( DbiCreateTable( DestDatabase.Handle, True, CrtTableDesc ) );
finally
FreeMem( CrtTableDesc.pFLDDesc, iDestMemSize );
end;
finally
FreeMem( pSrcFldDes, iSrcMemSize );
end;
finally
Session.CloseDatabase( DestDatabase );
end;
finally
Session.CloseDatabase( SrcDatabase );
end;
end;

[001393]


Цветная кнопка

VS пишет:

В книгах Калверта, Свана и других авторов можно найти похожий текст. Смысл текста – "Изменить цвет кнопок Button, BitBtn нельзя, т.к. их рисует WINDOWS". Если нельзя, но ОЧЕНЬ НУЖНО, то можно.

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

Примечание. Кнопку по-прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Чаще заглядывайте в VCL - можно найти много интересного. На рисунке представлены ColorButton и ColorBitBtn.

unit colorbtn;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;

type
TColorBtn = class(TButton)
private
FCanvas: TCanvas;
IsFocused: Boolean;
F3DFrame: boolean;
FButtonColor: TColor;
procedure Set3DFrame(Value: boolean);
procedure SetButtonColor(Value: TColor);
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Longint);
procedure CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Longint);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace;
property Frame3D: boolean read F3DFrame write Set3DFrame default False;
end;

procedure Register;

implementation

{ TColorBtn }
constructor TColorBtn.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
Height:= 21;
FCanvas:= TCanvas.Create;
FButtonColor:= clBtnFace;
F3DFrame:= False;
end;

destructor TColorBtn.Destroy;
begin
FCanvas.Free;
Inherited Destroy;
end;

procedure TColorBtn.CreateParams(var Params: TCreateParams);
begin
Inherited CreateParams(Params);
with Params do Style:= Style or BS_OWNERDRAW;
end;

procedure TColorBtn.Set3DFrame(Value: boolean);
begin
if F3DFrame <> Value then F3DFrame:= Value;
end;

procedure TColorBtn.SetButtonColor(Value: TColor);
begin
if FButtonColor <> Value then begin
FButtonColor:= Value;
Invalidate;
end;
end;

procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TColorBtn.SetButtonStyle(ADefault: Boolean);
begin
if IsFocused <> ADefault then IsFocused:= ADefault;
end;

procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem);
var
RC: TRect;
Flags: Longint;
State: TButtonState;
IsDown, IsDefault: Boolean;
DrawItemStruct: TDrawItemStruct;
begin
DrawItemStruct:= Message.DrawItemStruct^;
FCanvas.Handle:= DrawItemStruct.HDC;
RC:= ClientRect;
with DrawItemStruct do begin
IsDown:= ItemState and ODS_SELECTED <> 0;
IsDefault:= ItemState and ODS_FOCUS <> 0;
if not Enabled then State:= bsDisabled
else if IsDown then State:= bsDown
else State:= bsUp;
end;
Flags:= DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if IsDown then Flags:= Flags or DFCS_PUSHED;
if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then Flags:= Flags or DFCS_INACTIVE;
if IsFocused or IsDefault then begin
FCanvas.Pen.Color:= clWindowFrame;
FCanvas.Pen.Width:= 1;
FCanvas.Brush.Style:= bsClear;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
end;
if IsDown then begin
FCanvas.Pen.Color:= clBtnShadow;
FCanvas.Pen.Width:= 1;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
if F3DFrame then begin
FCanvas.Pen.Color:= FButtonColor;
FCanvas.Pen.Width:= 1;
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
end;
end else
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
FCanvas.Brush.Color:= FButtonColor;
FCanvas.FillRect(RC);
InflateRect(RC, 1, 1);
if IsFocused then begin
RC:= ClientRect;
InflateRect(RC, -1, -1);
end;
FCanvas.Font:= Self.Font;
if IsDown then OffsetRect(RC, 1, 1);
DrawButtonText(Caption, RC, State, 0);
if IsFocused and IsDefault then begin
RC:= ClientRect;
InflateRect(RC, -4, -4);
FCanvas.Pen.Color:= clWindowFrame;
Windows.DrawFocusRect(FCanvas.Handle, RC);
end;
FCanvas.Handle:= 0;
end;

procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Integer);
var
TB: TRect;
TS, TP: TPoint;
begin
with FCanvas do begin
TB:= Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or BiDiFlags);
TS:= Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
TP.X:= ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
TP.Y:= ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
TRC:= TB;
end;
end;

procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Integer);
begin
with FCanvas do begin
CalcuateTextPosition(Caption, TRC, BiDiFlags);
Brush.Style:= bsClear;
if State = bsDisabled then begin
OffsetRect(TRC, 1, 1);
Font.Color:= clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TRC, -1, -1);
Font.Color:= clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end else
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;

procedure Register;
begin
RegisterComponents('Controls', [TColorBtn]);
end;

end.

Небольшое дополнение. Кнопку по прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Хочется повторить слова Калверта – "Пользуйтесь исходным кодом". Чаще заглядывайте в VCL - можно найти много интересного. [001324]


Delphi 1

Обработка щелчка нескольких кнопок, используя их заголовок

...с ваших слов я понял, что вы все уже реализовали, но давайте все повторим: вы должны убедиться в том, что событие OnClick привязано к каждой кнопке калькулятора (числовые кнопки 0..9) и указывают на общий обработчик события.

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

Edit1.Text := TButton(Sender).Caption;

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

  1. назначьте уникальный Tag для каждой кнопки (например, эквивалент арабским цифрам)
  2. procedure TForm1.Button1Click(Sender: TObject);
    begin
    if (Sender is TButton) then
    with (Sender as TButton) do
    {используем Tag}
    end;

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

procedure TForm1.Edit1Click(Sender: TObject);
begin
edit1.text := (sender as TButton).caption ;
end;

Приведенная ниже конструкция будет недостаточной:

sender.caption

поскольку компилятор не знает о том, имеет ли "sender" свойство caption, или нет. [001523]


Delphi 1

Массив из CheckBox - использование разделяемого обработчика события I

Поместите несколько Checkbox в компонент TGroupBox. Во время прогона (или проектирования) назначьте общий обработчик события Click для всех checkbox'в. Чтобы в цикле обойти все "дочерние" TCheckBox'ы, можно воспользоваться свойством-массивом Controls TGroupBox (и заодно привести их к типу TCheckBox). Приблизительно так:

for i := 0 to GroupBox1.ControlCount -1 do
if (GroupBox1.Controls[i] as TCheckBox).checked then
{что-то там еще};

Вы можете получить имя sender следующим образом:

procedure TMain1.CheckBoxClick(Sender: TObject);
var
whodidit  : string[63];

begin
whodidit := TComponent(sender).name;
end;

После приведения типа можно добраться и до других свойств. К примеру, очень полезным может оказаться свойство Tag. Во время создания, вы можете присвоить каждому checkbox.tag свой ID номер. А в обработчике события, читая ID, можно идентифицировать sender. [001476]


Delphi 1

Массив из CheckBox - использование разделяемого обработчика события II

var
CheckArray: array[1..x] of TCheckBox;
i:integer;
begin
for i:=1 to x do begin
CheckArray[i]:=TCheckBox.Create(Form1);
{Устанавливаем свойства}
with CheckBox[i] do begin
Left:=i*20;
Width:=15;
другое...
end;
end;

Очевидно, можно сказать:

Check[i].OnClick:=xyz.

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

Существует способ организации массива checkbox'ов с разделяемым обработчиком события. Расположите их на форме и дайте им "непрерывные" имена (Check1, Check2 и т.д.). Затем установите у них общий обработчик события. Обработчик события может выглядеть так:

procedure TForm.Check1Click(Sender : TObject);
var
i : Integer;
begin
for i := 1 to 10 { предположим, что мы имеем 10 checkbox'ов } do
With TCheckBox(FindComponent('Check'+IntToStr(i))) do begin
{ другой какой-то код }
end;
end;

[001478]


Delphi 3

Идентификация CheckBox'ов

В режиме проектирования вы, как программист, без труда узнаете, сколько checkbox'ов содержит ваша форма. А вот когда приложение запущено... Используйте Delphi Run Time Type Information (RTTI). Для нашей испытуемой формы вы можете попробовать следующий код:

var
i : Integer
begin
for i := 0 to ComponentCount - 1 do:
if Components[i] is TCheckBox then
(Components[i] as TCheckBox).Checked then
begin
... сюда поместите ваш код ...
end;
end;

Кроме того, следующий код Delphi абсолютно корректен:

if Components[i] = CheckBox5 then
Чтотоделаем;

Также, каждый компонент в Delphi имеет опубликованное (Published) свойство с именем 'Tag', значение которого вы можете задавать во время создания компонента, и затем, во время выполнения приложения, обращаться к нему для получения доступа к компоненту:

var
i : Integer
begin
for i := 0 to ComponentCount - 1 do:
if Components[i] is TCheckBox then
with (Components[i] as TCheckBox) do
Case Tag of
1 : if Checked then DoSomethingOnBox1;
2 : if Checked then DoSomethingOnBox2;
... другое ...
end;
end;

Для получения дополнительной информации, обратитесь к справке Delphi с ключевым словом "ComponentCount". [001509]


Кнопка с несколькими строчками текста III

Вот полный код проекта, создающего на кнопке во время выполнения две строчки текста.

Файл TWOLNBTN.DPR

program TwolnBtn;

uses
Forms,
TwolnBtu in 'TWOLNBTU.PAS' {Form1};

{$R *.RES}

begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Файл TWOLNBTU.TXT => TWOLNBTU.DFM

object Form1: TForm1
Left = 202
Top = 98
Width = 320
Height = 176
Caption = 'Form1'
Font.Color = clRed
Font.Height = -12
Font.Name = 'Arial'
Font.Style = [fsBold]
PixelsPerInch = 96
OnActivate = ChgSpeedButton
OnCreate = ChgBitBtn
TextHeight = 15
object SpeedButton1: TSpeedButton
Left = 144
Top = 24
Width = 65
Height = 45
Caption = 'Это двустрочный заголовок'
OnClick = ChgSpeedButton
end
object BitBtn1: TBitBtn
Left = 32
Top = 24
Width = 69
Height = 37
Caption = 'Прерывание работы программы'
TabOrder = 0
OnClick = BitBtn1Click
end
end

Файл TWOLNBTU.PAS

unit Twolnbtu;

interface

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

type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
SpeedButton1: TSpeedButton;
procedure ChgBitBtn(Sender: TObject);
procedure ChgSpeedButton(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ChgBitBtn(Sender: TObject);
VAR
R : TRect;
N : Integer;
Buff : ARRAY[0..255] OF Char;
BEGIN
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;
END;

procedure TForm1.ChgSpeedButton(Sender: TObject);
VAR
R : TRect;
N : Integer;
Buff : ARRAY[0..255] OF Char;
BEGIN
WITH SpeedButton1 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;
END;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Close;
end;

end.

-Dennis Passmore [001062]


Delphi 1

Какая кнопка Sender?

...я полагаю, что вы могли бы воспользоваться свойством панели PopupMenu и использовать событие кнопки MouseDown чтобы делать то, что вы делали выше. Также, я полагаю, вы должны выключить свойство Auto. Затем поместите в обработчик события OnMouseDown следующий код:

procedure TForm1.BitBtn1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
begin
with Sender as TBitBtn do
if Button = mbRight then
begin
P := Self.ClientToScreen (
Point (Left + (Width div 2), Top + (Height div 2)));
PopupMenu1.Popup (P.X,P.Y);
end;
end;

[001639]


Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?

Nomadic отвечает:

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

unit edit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type

TPopupListbox = class(TCustomListbox)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
end;

TTestDropEdit = class(TEdit)
private
FPickList: TPopupListbox;
procedure CMCancelMode(var Message: TCMCancelMode); message CM_CancelMode;
procedure WMKillFocus(var Message: TMessage); message WM_KillFocus;
protected
procedure CloseUp(Accept: Boolean);
procedure DropDown;
procedure WndProc(var Message: TMessage); override;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
end;

implementation

{  TPopupListBox  }

procedure TPopupListBox.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
begin
Style := Style or WS_BORDER;
ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
WindowClass.Style := CS_SAVEBITS;
end;
end;

procedure TPopupListbox.CreateWnd;
begin
inherited CreateWnd;
Windows.SetParent(Handle, 0);
CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
end;

procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and (X < Width) and (Y < Height));
end;

{  TTestDropEdit  }

constructor TTestDropEdit.Create(Owner: TComponent);
begin
inherited Create(Owner);
Parent := Owner as TWinControl;
FPickList := TPopupListbox.Create(nil);
FPickList.Visible := False;
FPickList.Parent := Self;
FPickList.IntegralHeight := True;
FPickList.ItemHeight := 11;
FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0';
end;

destructor TTestDropEdit.Destroy;
begin
FPickList.Free;
inherited;
end;

procedure TTestDropEdit.CloseUp(Accept: Boolean);
begin
if FPickList.Visible then
begin
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
if FPickList.ItemIndex <> -1 then
Text := FPickList.Items.Strings[FPickList.ItemIndex];
FPickList.Visible := False;
Invalidate;
end;
end;

procedure TTestDropEdit.DropDown;
var
P: TPoint;
I,J,Y: Integer;
begin
if Assigned(FPickList) and (not FPickList.Visible) then
begin
FPickList.Width := Width;
FPickList.Color := Color;
FPickList.Font := Font;
FPickList.Height := 6 * FPickList.ItemHeight + 4;
FPickList.ItemIndex := FPickList.Items.IndexOf(Text);
P := Parent.ClientToScreen(Point(Left, Top));
Y := P.Y + Height;
if Y + FPickList.Height > Screen.Height then Y := P.Y - FPickList.Height;
SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0,
SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
FPickList.Visible := True;
Invalidate;
Windows.SetFocus(Handle);
end;
end;

procedure TTestDropEdit.CMCancelMode(var Message: TCMCancelMode);
begin
if (Message.Sender <> Self) and (Message.Sender <> FPickList) then
CloseUp(False);
end;

procedure TTestDropEdit.WMKillFocus(var Message: TMessage);
begin
inherited;
CloseUp(False);
end;

procedure TTestDropEdit.WndProc(var Message: TMessage);
procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);
begin
case Key of
VK_UP, VK_DOWN:
if ssAlt in Shift then begin
if FPickList.Visible  then CloseUp(True) else DropDown;
Key := 0;
end;
VK_RETURN, VK_ESCAPE:
if FPickList.Visible  and not (ssAlt in Shift) then begin
CloseUp(Key = VK_RETURN);
Key := 0;
end;
end;
end;
begin
case Message.Msg of
WM_KeyDown, WM_SysKeyDown, WM_Char:
with TWMKey(Message) do begin
DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));
if (CharCode <> 0) and FPickList.Visible then begin
with TMessage(Message) do
SendMessage(FPickList.Handle, Msg, WParam, LParam);
Exit;
end;
end
end;
inherited;
end;

end.

[001112]


Delphi 1

Программное открытие ComboBox II

procedure TForm1.ComboBox1Enter(Sender:TObject);
begin
SendMessage(ComboBox1.Handle,CB_SHOWDROPDOWN,Integer(True),0);
end;

Поместите эту строку в обработчико события OnEnter ComboBox:

SendMessage(combobox1.Handle, CB_SHOWDROPDOWN, 1, 0);

Измените третий параметр (1) на 0, если вы хотите спрятать список. [001481]


Delphi 1

Проблемы с ComboBox

...попробуйте сохранять в переменной в методе формы OnEnter или OnCreate значение Index. Затем, чтобы отменить выбор пользователя, сделайте:

ComboBox1.ItemIndex := var1;

[001483]


Know-how

Hint в выпадающем списке ComboBox

VS пишет:

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

В демонстрационном примере в выпадающем списке появляется всплывающая подсказка для строки не помещающейся по длине.

При работе с Hint нужно помнить – использовать ToolTip из API, бесполезная затея. Delphi игнорирует любые попытки работы ним. Для этих целей в Delphi предусмотрен класс – THintWindow.

В своем компоненте объявите FTipHint:

type
TVSComboBox = class(TCustomComboBox)
…
private
FHint: THintWindow;
…
protected
procedure WMCTLCOLORLISTBOX(var Message: TMessage); message WM_CTLCOLORLISTBOX;

и не забудьте выполнить инициализацию в конструкторе вашего компонента:

…
begin
inherited Create(AOwner);
FHint := THintWindow.Create(Self);
…

Чтобы получить информацию об активной строке в выпадающем списке ComboBox перехватите сообщение WM_CTLCOLORLISTBOX. В процедуре сообщения анализируйте - если длина строки больше ширины выпадающего списка – передайте "длинную" строку в ваш Hint и активируйте его:

FHint.ActivateHint(TextRC, Items[ItemIndex]);

где
TextRC – прямоугольник для строки подсказки
Items[ItemIndex] – "длинная" строка из выпадающего списка

Если активная строка в выпадающем списке "короткая" – спрячьте Hint:

FHint.ReleaseHandle;

Для получения подробной информации о классе THintWindow воспользуйтесь Help из Delphi. [001758]


Delphi 1

Исправление DBEdit MaxLength

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

По-моему, это является следствием этого кода в TDBEdit.DataChange (DBCTRLS.PAS):

if FDataLink.Field <> nil then
begin
...
if FDataLink.Field.DataType = ftString then
MaxLength := FDataLink.Field.Size else
MaxLength := 0;
...
end else
begin
...
MaxLength := 0;
...
end;

т.к. иногда значение устанавливается на ноль...

Похоже все будет работать, если вы измените строку

MaxLength := 0;

на

MaxLength := inherited MaxLength;

Для того, чтобы изменения вступили в силу, вам необходимо перекомпилировать ваш complib с измененным DBCTRLS.PAS, находящимся в пути lib.

Если вы хотите использовать MaxLength с StringField, изменений необходимо сделать немного больше:

...
if (FDataLink.Field.DataType = ftString)
and (inherited MaxLength = 0) then
MaxLength := FDataLink.Field.Size else
MaxLength := inherited MaxLength;
...

Или использовать что-то типа EditMask...

- Reinhard Kalinke [001021]


Поиск и управление TEdit/TField

Я хотел бы менять цвет компонентов TDBEdit и TEdit, расположенных на форме, на другой, "отчетливый" цвет, в том случае, если с помощью них требуется ввести какие-либо данные.

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

procedure TForm3.Button3Click(Sender: TObject);
Var
Control : Integer;
begin
For Control := 0 To ControlCount-1 Do
If Controls[Control] Is TDBEdit
Then With TDBEdit(Controls[Control]) Do
If DataSource.DataSet.FieldByName ( DataField ).Required
Then Color := clRed;
end;

{ Данный метод будет работать только в случае, если БД-компонент обладает тремя полями: DataSource, типа TDataSource, DataField, типа String, и Color, типа TColor (это не должно быть проблемой). Также вам необходимо включить TypInfo в список используемых модулей }

procedure TForm3.Button4Click(Sender: TObject);
Var
Control : Integer;

DataSource : TDataSource;
DataField  : String;

Function GetDataSource ( Instance : TComponent ) : Boolean;
Var
PropInfo : PPropInfo;
Begin
Result := False;
PropInfo := TypInfo.GetPropInfo ( Instance.ClassInfo, 'DataSource' );
If ( PropInfo <> Nil ) And
( PropInfo^.PropType^.Kind = tkClass )
Then Begin
DataSource := TDataSource ( TypInfo.GetOrdProp ( Instance, PropInfo ) );
Result := DataSource <> Nil;
End;
End;

Function GetDataField ( Instance : TComponent ) : Boolean;
Var
PropInfo : PPropInfo;
Begin
Result := False;
PropInfo := TypInfo.GetPropInfo ( Instance.ClassInfo, 'DataField' );
If ( PropInfo <> Nil ) And
( PropInfo^.PropType^.Kind = tkString )
Then Begin
DataField := TypInfo.GetStrProp ( Instance, PropInfo );
Result := True;
End;
End;

Procedure SetColor ( Instance : TComponent; Color : TColor );
Var
PropInfo : PPropInfo;
Begin
PropInfo := TypInfo.GetPropInfo ( Instance.ClassInfo, 'Color' );
If ( PropInfo <> Nil ) And
( PropInfo^.PropType^.Kind = tkInteger )
Then TypInfo.SetOrdProp ( Instance, PropInfo, Ord(Color) );
End;

begin
For Control := 0 To ControlCount-1 Do
If GetDataSource ( Controls[Control] ) And
GetDataField ( Controls[Control] ) And
( DataSource.DataSet <> Nil ) And
DataSource.DataSet.FieldByName ( DataField ).Required
Then SetColor ( Controls[Control], clRed );
end;

- Robert Wittig [001046]


Insert/Override с помощью DBEdit

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

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

private
FinsertMode: boolean;
procedure SetInsertMode(value: boolean);
public
property insertMode: boolean read FinsertMode write SetInsertMode;

В обработчике создания события формы я инициализирую его:

procedure TForm1.FormCreate(Sender: TObject);
begin
{инициализация}
insertMode := True;
end;

Также для этого свойства я создаю процедуру SetInsertMode, которая с помощью TPanel с именем Panel1 извещает пользователя о текущем режиме работы:

procedure TForm1.SetInsertMode(value: boolean);
begin
FinsertMode := value;
if FinsertMode then
Panel1.Caption := 'ВСТАВКА'
else
Panel1.Caption := 'ПЕРЕЗАПИСЬ';
end;

Затем я добавляю три обработчика событий (OnKeyDown, OnKeyPress, OnEnter) для каждого моего DBEdit (можно при наличии нескольких компонентов создать один общий обработчик для всех):

procedure TForm1.DBEditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_INSERT) then
insertMode := not insertMode;
end;

procedure TForm1.DBEditKeyPress(Sender: TObject; var Key: Char);
begin
if (not insertMode) and (Sender is TDBEdit) then
(Sender as TDBEdit).SelLength := 1
else
(Sender as TDBEdit).SelLength := 0;
end;

procedure TForm1.DBEditEnter(Sender: TObject);
begin
insertMode := True;
end;

Банзай! Похоже это работает, хотя я и не имел достаточного времени протестировать это. Естественно, вы можете изменить это по просьбе вашего заказчика (например, я всегда сбрасывал режим во вставку при перемещении к другому компоненту DBEedit). Все вышесказанное должно также работать без проблем и с компонентами Edit.

- Denis Sarrazin [001049]


Delphi 1

Как очистить DBEdit

Пробую так:

myDbEdit.Text := '';

или адрес TField, если вы хотите так:

TableNameMyField.Value := '';

Ответ:

Table1.Edit;
Table1.FieldByName(DBEdit1.FieldName).Clear;

[001533]


Delphi 2

Dbgrid и множественный выбор

Тема: TDBGrid и множественный выбор записей (Multi-Selecting Records)

При включении флажка [dgMultiSelect] в свойстве-наборе Options компонента DBGrid, вы добавляете к табличной сетке возможность множественного выбора записей.

Выбранные вами записи представлены в виде закладок и храняться в свойстве SelectedRows.

Свойство SelectedRows является объектом, имеющим тип TBookmarkList. Его свойства и методы описаны ниже.

// property SelectedRows: TBookmarkList read FBookmarks;

//   TBookmarkList = class
//   public

{* Метод Clear освобождает все выбранные в DBGrid записи *}
// procedure Clear;

{* Метод Delete удаляет все выбранные строки из набора данных *}
// procedure Delete;

{* Метод Find определяет наличие закладки в выбранном списке. *}
// function  Find(const Item: TBookmarkStr;
//      var Index: Integer): Boolean;

{* Метод IndexOf возвращает индекс закладки, расположенной в свойстве Items. *}
// function IndexOf(const Item: TBookmarkStr): Integer;

{* Метод Refresh возвращает логическую величину, уведомляющую о том, что в то время, пока в табличной сетке была выбрана запись, были добавлены (удалены) какие-то данные. Метод Refresh может быть использован для обновления списка выбранных записей для уменьшения возможности получения удаленной записи. *}
// function Refresh: Boolean;  True = orphans found

{* Свойство Count возвращает количество выбранных в настоящий момент элементов в DBGrid *}
// property Count: Integer read GetCount;

{* Свойство CurrentRowSelected содержит логическую величину, зависящую от того, выбрана текущая строка или нет. *}
// property CurrentRowSelected: Boolean
//      read GetCurrentRowSelected
//      write SetCurrentRowSelected;

{* Свойство Items - TStringList TBookmarkStr *}
// property Items[Index: Integer]: TBookmarkStr
//      read GetItem; default;

//  end;
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables;

type
TForm1 = class(TForm)
Table1: TTable;
DBGrid1: TDBGrid;
Count: TButton;
Selected: TButton;
Clear: TButton;
Delete: TButton;
Select: TButton;
GetBookMark: TButton;
Find: TButton;
FreeBookmark: TButton;
DataSource1: TDataSource;
procedure CountClick(Sender: TObject);
procedure SelectedClick(Sender: TObject);
procedure ClearClick(Sender: TObject);
procedure DeleteClick(Sender: TObject);
procedure SelectClick(Sender: TObject);
procedure GetBookMarkClick(Sender: TObject);
procedure FindClick(Sender: TObject);
procedure FreeBookmarkClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Bookmark1: TBookmark;
z: Integer;

implementation

{$R *.DFM}

//Пример использования свойства Count
procedure TForm1.CountClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.Count > 0 then
begin
showmessage(inttostr(DBgrid1.SelectedRows.Count));
end;
end;

//Пример использования свойства CurrentRowSelected
procedure TForm1.SelectedClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.CurrentRowSelected then
showmessage('Выбрана');
end;

//Пример использования метода Clear
procedure TForm1.ClearClick(Sender: TObject);
begin
dbgrid1.SelectedRows.Clear;
end;

//Пример использования метода Delete
procedure TForm1.DeleteClick(Sender: TObject);
begin
DBgrid1.SelectedRows.Delete;
end;

{*
Данные пример проходит в цикле все выбранные
записи табличной сетки и отображает второе
поле набора данных.

Метод DisableControls используется в случае,
когда необходимо запретить обновление DBGrid
при изменении набора данных. Последняя позиция
набора данных сохраняется как TBookmark.

Метод IndexOf вызывается при необходимости
проверить существование закладки.
Решение использовать метод IndexOf, а не
Refresh, должно приниматься исходя из
специфики приложения.
*}

procedure TForm1.SelectClick(Sender: TObject);
var
x: word;
TempBookmark: TBookMark;
begin
DBGrid1.Datasource.Dataset.DisableControls;
with DBgrid1.SelectedRows do
if Count > 0 then
begin
TempBookmark:= DBGrid1.Datasource.Dataset.GetBookmark;
for x:= 0 to Count - 1 do
begin
if IndexOf(Items[x]) > -1 then
begin
DBGrid1.Datasource.Dataset.Bookmark:= Items[x];
showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
end;
end;
end;
DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.EnableControls;
end;

{*
Данный пример позволит вам установить закладку и
затем найти ее в списке выбранных записей
компонента DBGrid.
*}
//Устанавливаем закдадку
procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
Bookmark1:= DBGrid1.Datasource.Dataset.GetBookmark;
end;

//Освобождаем закладку
procedure TForm1.FreeBookmarkClick(Sender: TObject);
begin
if assigned(Bookmark1) then
begin
DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
Bookmark1:= nil;
end;
end;

//Испольуем метод Find для установления позиции
//записи-закладки в списке выбранных записей компонента DBGrid
procedure TForm1.FindClick(Sender: TObject);
begin
if assigned(Bookmark1) then
begin
if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1),z) then
showmessage(inttostr(z));
end;
end;

end.

[001010]


Delphi 1

Вертикальная полоса прокрутки Dbgrid

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

(Примечание: это работает только с таблицами Paradox и BDE. Для использования этого кода с другими таблицами/движками вам необходимо заменить DBIGetSeqNo на функцию, надежно возвращающую текущую позицию записи вне зависимости от того, использует ли таблица индекс или нет.)

В DBGRID.PAS измените две следующих процедуры:

procedure TCustomDBGrid.UpdateScrollBar;
var
Pos: Integer;
mPos, mMax: longint;
begin
if FDatalink.Active and HandleAllocated then
with FDatalink.DataSet do
begin
UpdateCursorPos;
if (DBIGetSeqNo(Handle,mPos) = DBIERR_NONE) then
begin
mMax := RecordCount;
while mMax > 1000 do
begin
mMax := mMax div 10;
mPos := mPos div 10;
end;
SetScrollRange(Self.Handle, SB_VERT, 1, mMax, False);
end
else
begin
if BOF then mPos := 0
else if EOF then mPos := 4
else mPos := 2;
SetScrollRange(Self.Handle, SB_VERT, 0, 4, False);
end;   (**)
if GetScrollPos(Self.Handle, SB_VERT) <> mPos then
SetScrollPos(Self.Handle, SB_VERT, mPos, True);
end;
end;

procedure TCustomDBGrid.WMVScroll(var Message: TWMVScroll);
var mMin, mMax: integer;
RecCount, RecNo, NewRecNo: longint;
begin
if not AcquireFocus then Exit;
if FDatalink.Active then
with Message, FDataLink.DataSet, FDatalink do
case ScrollCode of
SB_LINEUP: MoveBy(-ActiveRecord - 1);
SB_LINEDOWN: MoveBy(RecordCount - ActiveRecord);
SB_PAGEUP: MoveBy(-VisibleRowCount);
SB_PAGEDOWN: MoveBy(VisibleRowCount);
SB_THUMBPOSITION:
if (DBIGetSeqNo(Handle,RecNo) = DBIERR_NONE) then
begin
GetScrollRange(self.Handle, SB_VERT, mMin, mMax);
NewRecNo := Pos*(FDataLink.DataSet.RecordCount div mMax);
MoveBy(NewRecNo-RecNo);
end
else
case Pos of
0: First;
1: MoveBy(-VisibleRowCount);
2: Exit;
3: MoveBy(VisibleRowCount);
4: Last;
end;
SB_BOTTOM: Last;
SB_TOP: First;
end;
end;

Имейте в виду, что из-за небольшой ошибки в VCL (MoveBy использует integer-параметр вместо longint), могут быть проблемы с большими таблицами (RecordCount>MaxInt). Объяснение этому факту я нашел в журнале Delphi Magazine. Для больших таблиц вы должны заменить вызовы MoveBy на DBISetToSeqNo или DBIGetRelativeRecord. Не забудьте после данного вызова вызвать Resnyc([]) или Refresh!

P.S. Пока вы ковыряетесь в DBGRIDS.PAS: найдите и замените TitleColor на FixedColor в TCustomDBGrid.Create и в TCustomDBGrid.DrawCell. Значение свойства FixedColor влияет на показ заголовков колонок, и они будут выводится как и ожидалось.

- Reinhard Kalinke [001019]


Delphi 2

TDBGrid Lookup-поле в D2

Как создать lookup-поле в TDBGrid для Delphi 2.0

  1. Разместите на форме 2 компонента TTable, 1 компонент TDataSource и 1 - TDBGrid.
  2. Подключите Table1 - к DataSource1 - к DBGrid1
    • DataSource1.DataSet = Table1
    • DBGrid1.DataSource = DataSource1
  3. Установка Table1
    • Table1.Database = DBDemos
    • Table1.TableName = Customer
    • Table1.Active = True
  4. Установка Table2
    • Table2.Database = DBDemos
    • Table2.TableName = Orders
    • Table2.Active = True
  5. Добавьте все поля для Table1, используя Fields Editor (редактор полей):
    • Дважды щелкните на Table1
    • Нажмите правую кнопку мыши в редакторе полей
    • Выберите пункт Add New Fields. Добавьте их все.
  6. Добавьте новое поле для Table1.
    • Нажмите правую кнопку мыши в редакторе полей и выберите пункт "New Field".
  7. Определите следующие параметры для вновь добавленного поля:
    • Name: Bob
    • Type: String
    • Size: 30
    • Select Lookup
    • Key Fields: CustNo - Поле в Table1 для хранения значения
    • DataSet: Table2 - Здесь устанавливается табличный lookup
    • LookUpKeys: CustNo - Данный ключ копируется в KeyField
    • Result Field: OrderNo - Значение для показа пользователю в выпадающем списке
  8. Запустите приложение
[001023]


Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

Nomadic советует:

Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную задачу.

// DBGRIDEX.PAS
// ----------------------------------------------------------------------------
 -
destructor TDbGridEx.Destroy;
begin

_HideColumnsValues.Free;
_HideColumns.Free;

inherited Destroy;
end;

// ----------------------------------------------------------------------------
constructor TDbGridEx.Create(Component : TComponent);
begin
inherited Create(Component);

FFreezeCols   := ?;

_HideColumnsValues := TList.Create;
_HideColumns       := TList.Create;
end;

// ----------------------------------------------------------------------------
 procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
begin
if (Key = VK_LEFT) then ColBeforeEnter(-1);
if (Key = VK_RIGHT) then ColBeforeEnter(1);

inherited;
end;

// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeColor(AColor : TColor);
begin
InvalidateRow(0);
end;

// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeCols(AFreezeCols : Integer);
begin
FFreezeCols := AFreezeCols;
InvalidateRow(0);
end;

// ----------------------------------------------------------------------------
procedure TDbGridEx.ColEnter;
begin
ColBeforeEnter(0);

if Assigned(OnColEnter) then OnColEnter(Self);
end;

// ----------------------------------------------------------------------------
procedure TDbGridEx.ColBeforeEnter(ADelta : Integer);
var
nIndex : Integer;

function ReadWidth : Integer;
var
i : Integer;

begin
i := _HideColumns.IndexOf(Columns[nIndex]);

if i = -1
then result := 120
else result := Integer(_HideColumnsValues[i]);
end;

procedure SaveWidth;
var
i : Integer;

begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i <> - 1 then
begin
_HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
end else
begin
_HideColumns.Add(Columns[nIndex]);
_HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
end;
end;

begin
for nIndex := 0 to Columns.Count - 1 do
begin
if (Columns[nIndex].Width = 0)  then
begin
if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta)
then Columns[nIndex].Width := ReadWidth;
end
else
begin
SaveWidth;
if (nIndex + 1 > FreezeCols) and
(nIndex < SelectedIndex + ADelta) and
(nIndex + 1 < Columns.Count) and
(FreezeCols > 0)
then Columns[nIndex].Width := 0;
end;
end;
end;

[001098]


Dbgrid с цветными ячейками IV

Nomadic советует:

Hапример, так:

DefaultDrawing:=False;
....
procedure TfrmCard.GridDrawColumnCell(Sender: TObject; constRect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
Index : Integer;
Marked, Selected: Boolean;
begin

Marked := False;
if (dgMultiSelect in Grid.Options) and THackDBGrid(Grid).Datalink.Active then
Marked:=Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark,Index);

Selected := THackDBGrid(Grid).Datalink.Active and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord);

if Marked then
begin
Grid.Canvas.Brush.Color:=$DFEFDF;
Grid.Canvas.Font.Color :=clBlack;
end;

if Selected then
begin
Grid.Canvas.Brush.Color:=$FFFBF0;
Grid.Canvas.Font.Color :=clBlack;
if Marked then
Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
end;

Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;

где

THackDBGrid = class(TDBGrid)
property DataLink;
property UpdateLock;
end;

Обратите внимание на обьявление класса THackDBGrid. Таким образом можно получить доступ к приватным полям, свойствам и методам класса, что, к сожалению, приходится делать, если авторы исходного класса оказались не предусмотрительны. [001138]


Delphi 1

Dbgrid с цветными ячейками V

Попробуйте следующий код в обработчике события 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;

Установите рисование по умолчинию (Default drawing) в True. Только после этого можно нарисовать выделенную ячейку. Если вы установили DefaultDrawing в False, вы должны сами рисовать все ячейки, используя свойство Canvas. [001470]


Что я получаю от наличия ConstraintBroker (брокера ограничений)?

Nomadic отвечает:

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


Delphi 1

Улучшенный Dbgrid

{
Код улучшенного TDBGrid, имеющего свойства Col, Row и Canvas и метод CellRect. Это чрезвычайно полезно в случае, если вы, к примеру, хотите получить выпадающий список на месте редактируемой пользователем ячейки.
}
unit VUBComps;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, DBGrids, DB, Menus;

type
TDBGridVUB = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
public
property Canvas;
function CellRect(ACol, ARow: Longint): TRect;
property Col;
property Row;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('VUBudget', [TDBGridVUB]);
end;

function TDBGridVUB.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;

end.

[001167]


Delphi 3

Пример Drag and Drop между двумя Dbgrid

Данный пример компонента и демонстрационный проект показывают простой путь осуществления операции "drag and drop" (перетащи и брось) между двумя полями различных табличных сеток.

  1. Запустите Delphi 3 (с незначительными изменениями данный код может работать и в Delphi 1-2).

  2. Активизируйте File|New|Unit. Скопируйте приведенный ниже модуль MyDBGrid во вновь созданный модуль. Сделайте File|Save As. Сохраните модуль как MyDBGrid.pas.

  3. Выберите пункт меню Component|Install Component. Переключитесь на страницу Info New Package. Поместите MyDBGrid.pas в поле редактирования "Unit file name" (имя файла модуля). Назовите модуль MyPackage.dpk. Ответьте Yes на вопрос Delphi 3 о необходимости сборки и установки пакета. Нажмите OK на сообщение Delphi 3 о необходимости включения VCL30.DPL. После этого пакет будет собран и установлен. Теперь компонент TMyDBGrid будет отображен в Палитре Компонентов в группе "Samples". Закройте редактор пакетов и сохраните пакет.

  4. Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.

  5. Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.

  6. Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.
Модуль MyDBGrid

unit MyDBGrid;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Grids, DBGrids;

type
TMyDBGrid = class(TDBGrid)
private
{ Private declarations }
FOnMouseDown: TMouseEvent;
protected
{ Protected declarations }
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
published
{ Published declarations }
property Row;
property OnMouseDown read FOnMouseDown write FOnMouseDown;
end;

procedure Register;

implementation

procedure TMyDBGrid.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseDown) then
FOnMouseDown(Self, Button, Shift, X, Y);
inherited MouseDown(Button, Shift, X, Y);
end;

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

end.

Модуль GridU1

unit GridU1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;

type
TForm1 = class(TForm)
MyDBGrid1: TMyDBGrid;
Table1: TTable;
DataSource1: TDataSource;
Table2: TTable;
DataSource2: TDataSource;
MyDBGrid2: TMyDBGrid;
procedure MyDBGrid1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure MyDBGrid1DragOver(Sender, Source: TObject;
X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure MyDBGrid1DragDrop(Sender, Source: TObject;
X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
SGC : TGridCoord;

procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
DG : TMyDBGrid;
begin
DG := Sender as TMyDBGrid;
SGC := DG.MouseCoord(X,Y);
if (SGC.X > 0) and (SGC.Y > 0) then
(Sender as TMyDBGrid).BeginDrag(False);
end;

procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;
X, Y: Integer; State: TDragState; var Accept: Boolean);
var
GC : TGridCoord;
begin
GC := (Sender as TMyDBGrid).MouseCoord(X,Y);
Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;

procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;
X, Y: Integer);
var
DG     : TMyDBGrid;
GC     : TGridCoord;
CurRow : Integer;
begin
DG := Sender as TMyDBGrid;
GC := DG.MouseCoord(X,Y);
with DG.DataSource.DataSet do begin
with (Source as TMyDBGrid).DataSource.DataSet do
Caption := 'Вы перетащили "'+Fields[SGC.X-1].AsString+'"';
DisableControls;
CurRow := DG.Row;
MoveBy(GC.Y-CurRow);
Caption := Caption+' в "'+Fields[GC.X-1].AsString+'"';
MoveBy(CurRow-GC.Y);
EnableControls;
end;
end;

end.

Форма GridU1

object Form1: TForm1
Left = 200
Top = 108
Width = 544
Height = 437
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object MyDBGrid1: TMyDBGrid
Left = 8
Top = 8
Width = 521
Height = 193
DataSource = DataSource1
Row = 1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnDragDrop = MyDBGrid1DragDrop
OnDragOver = MyDBGrid1DragOver
OnMouseDown = MyDBGrid1MouseDown
end
object MyDBGrid2: TMyDBGrid
Left = 7
Top = 208
Width = 521
Height = 193
DataSource = DataSource2
Row = 1
TabOrder = 1
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnDragDrop = MyDBGrid1DragDrop
OnDragOver = MyDBGrid1DragOver
OnMouseDown = MyDBGrid1MouseDown
end
object Table1: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'ORDERS'
Left = 104
Top = 48
end
object DataSource1: TDataSource
DataSet = Table1
Left = 136
Top = 48
end
object Table2: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'CUSTOMER'
Left = 104
Top = 240
end
object DataSource2: TDataSource
DataSet = Table2
Left = 136
Top = 240
end
end

[001213]


Как заставить DBGrid сортировать данные по щелчку на заголовке столбца?

Nomadic советует:

Кyсочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с опpеделенным макpосом %Order. Работать не бyдет (без модyлей), но в качестве идеи может быть полезен.

unit vgRXutil;

interface

uses
SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;

{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);

function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;

{ TRxQuery }

{ Applicatable to SQL's without SELECT * syntax }

{ Inserts FieldName into first position in '%Order' macro and refreshes query }
 procedure HandleOrderMacro(Query: TRxQuery; Field: TField);

{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);

{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);

implementation
uses
 vgUtils, vgDBUtl, vgBDEUtl;

{ TrxDBLookup refresh }

type
TRXLookupControlHack = class(TrxLookupControl)
property DataSource;
property LookupSource;
property Value;
property EmptyValue;
end;

procedure RefreshRXLookup(Lookup: TrxLookupControl);
var
SaveField: String;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := DataField;
DataField := '';
DataField := SaveField;
end;
end;

procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var
SaveField: String;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := LookupDisplay;
LookupDisplay := '';
LookupDisplay := SaveField;
end;
end;

function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
with TRXLookupControlHack(Lookup) do
try
if Value <> EmptyValue then
Result := StrToInt(Value) else
Result := 0;
except
Result := 0;
end;
end;

procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
var
Param: TParam;
OldActive: Boolean;
OldOrder: String;
Bmk: TPKBookMark;
begin
 Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) then Exit;

OldOrder := Param.AsString;

if OldOrder <> NewOrder then
begin
OldActive := Query.Active;
if OldActive then Bmk := GetPKBookmark(Query, '');
try
Query.Close;
Param.AsString := NewOrder;
try
Query.Prepare;
except
Param.AsString := OldOrder;
end;
Query.Active := OldActive;
if OldActive then SetToPKBookMark(Query, Bmk);
finally
if OldActive then FreePKBookmark(Bmk);
end;
end;
end;

procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var
 NewOrderFields: TStrings;

procedure AddOrderField(S: String);
begin
if NewOrderFields.IndexOf(S) < 0 then
NewOrderFields.Add(S);
end;

var
I, J: Integer;
Field: TField;
FieldDef: TFieldDef;
S: String;
begin
NewOrderFields := TStringList.Create;
with Query do
try
for I := 0 to OrderFields.Count - 1 do
begin
S := OrderFields[I];
Field := FindField(S);
if Assigned(Field) and (Field.FieldNo > 0) then
AddOrderField(IntToStr(Field.FieldNo))
else
try
J := StrToInt(S);
if J < FieldDefs.Count then
AddOrderField(IntToStr(J));
except
end;
end;
OrderFields.Assign(NewOrderFields);
finally
NewOrderFields.Free;
end;
end;

procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
Param: TParam;
Tmp, OldOrder, NewOrder: String;
I: Integer;
C: Char;
TmpField: TField;
OrderFields: TStrings;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) or Field.Calculated or Field.Lookup then Exit;
OldOrder := Param.AsString;
I := 0;
Tmp := '';
OrderFields := TStringList.Create;
try
OrderFields.Ad(Field.FieldName);
while I < Length(OldOrder) do
begin
Inc(I);
C := OldOrder[I];
if C in FieldNameChars then
 Tmp := Tmp + C;

if (not (C in FieldNameChars) or (I = Length(OldOrder))) and (Tmp <> '') then
begin
TmpField := Field.DataSet.FindField(Tmp);
if OrderFields.IndexOf(Tmp) < 0 then
OrderFields.Add(Tmp);
Tmp := '';
end;
end;

UpdateOrderFields(Query, OrderFields);
NewOrder := OrderFields[0];
for I := 1 to OrderFields.Count - 1 do
NewOrder := NewOrder + ', ' + OrderFields[1];
finally
OrderFields.Free;
end;
InsertOrderBy(Query, NewOrder);
end;

end.

[001242]


Delphi 1

DBGrid и TQuery

  1. Расположите на вашей форме 2 TQuerie с двумя соответствующими TDatasource (Query1 будет вашим Мастером, Query2 будет вашей Деталью)

  2. Разместите 2 TDBGrid, связанных с Datasource'ами (вероятно, вы уже это сделали)

  3. Используйте базу данных, поставляемую с Delphi:

    Query1.SQL := 'Select * from customer'
    Query2.SQL := 'Select * from Orders where
    Orders."CustNo" = :CustNo'

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

  4. В свойствах Query2 выберите свойство Params и напишите в строке 'CustNo'. 'CustNo' был определен как параметр, поскольку в SQL строке было использовано ':'.

  5. ОЧЕНЬ ВАЖНО: установите Query2.Datasource в набор данных, связанный с Query1.

Каждый раз при изменении записи в наборе данных Query1, Query2 будет обновляться. Имя параметра 'CustNo' соответствует имени реального поля в таблице Customer.

P.S.: Для получения дополнительной информации обратитесь к разделу электронной справки 'dynamic SQL' [001246]


Delphi 1

DBGrid как навигатор

  1. Расположите компонент table на пустой форме и свяжите его с вашего таблицей Client.

  2. Добавьте компонент Datasource и свяжите его с компонентом table, описанным выше.

  3. Добавьте компонент grid и свяжите его с компонентом datasource, описанным выше.

  4. Используя Редактор Полей (Fields Editor), создайте компоненты TField для всех полей таблицы client.

  5. Установите свойство Visible всех компонентов TField, кроме Client Name (или другого поля, которое будет отображаться в DBGrid), в False. Gird теперь будет отображать только Client Name.

  6. Для отображения полей таблицы Client (которые вы хотите показать, или которые вы хотите сделать доступными для редактирования пользователем), ниже табличной сетки расположите компоненты DBEdit. Они могут использовать тот же набор данных, что и DBGrid.
Теперь пользователь может воспользоваться DBGrid для навигации и ввода/редактирования данных посредством DBEdit'ов. [001248]


Delphi 1

Позиция DBGrid

В режиме разработки дважды щелкните на компоненте TQuery, и выберите все поля, которые вы хотите использовать в DBGrid. Затем в обработчике события DBGrid doubleclick смотрите значение DBGrid.SelectedIndex. Если оно < 0, выбранных пунктов нет. Также, текущая запись TQuery будет указывать на ту же самую строку, которая выбранна в DBGrid. Таким образом, вы можете использовать что-то типа requiredvalue := Query1Field1.AsString; и т.д., естественно, компоненты TQuery и DBGrid должны быть подключены друг к другу. [001250]


Delphi 1

DBGrid - переход к следующей записи

Для перехода к следующей записи:

MyDBGrid.SelectedIndex := MyDBGrid.SelectedIndex + 1;

Колонки DBGrid индексируются с 0, поэтому SelectedIndex := 0 даст вам первую колонку. Свойство FieldCount вернет вам количество колонок, так что вы без труда можете пробежаться по всей матрице данных. [001252]


onClick и DBGrid

Многие программисты хотели бы использовать OnClick у TDBGrid. Но TDBGrid не имеет такого события. В данном документе рассказывается о том, как обеспечить поддержку события OnClick для TDBGrid. Рассказанная здесь технология может пригодиться при добавлении других свойств к различным объектам. Если вы знаете, что сделать это мог предок, то можно заставить сделать это и наследника. Ключевым моментом здесь можно считать добавление csClickEvents к свойству-набору элемента управления ControlStyle. Это позволит элементу управления, приведенному к типу THack, получать и правильно обрабатывать системные сообщение о щелчке мышью. Назначение OnClick какого-либо элемента управления OnClick DBGrid1 позволяет воспользоваться событием OnClick для элемента управления, которое его не поддерживает.

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

unit Udbgclk;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DBTables, DB;

type
thack = class(tcontrol);

TForm1 = class(TForm)
DBGrid1: TDBGrid;
Button1: TButton;
DataSource1: TDataSource;
Table1: TTable;
procedure Button1Click(Sender: TObject);
procedure FormClick(Sender: TObject);

private
{ Private declarations }
public

{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
THack(dbgrid1).controlstyle :=
THack(dbgrid1).controlstyle + [csClickEvents];
THack(dbgrid1).OnClick := Form1.OnClick;
end;

procedure TForm1.FormClick(Sender: TObject);
begin
messagebeep(0);
application.processmessages;
end;

end.

[001273]


Delphi 1

Числа с плавающей точкой в DBGrid

Для показа в табличной сетке дробных чисел, выберите таблицу, с которой связана ваша сетка (через datasource, источник данных).

Активизируйте редактор полей (правой кнопкой мыши) и выберите поле, в котором вы хотите видеть дробное число.

Измените значение свойств 'DisplayFormat' и 'EditFormat', чтобы дробь имела формат такой, какой вы хотите (к примеру, шаблон '0.00', позволяющий сетке показывать поле с двумя цифрами после запятой).

Дважды щелкните на компоненте table, расположенном на форме. Нажмите на кнопку 'Add'. Будут показаны все поля вашей таблицы. Выберите их в списке "Available field" (доступные поля) и щелкните на кнопке OK. Теперь при щелчке на имени поля, в Инспекторе Объектов будут показаны все свойства, относящиеся к данному полю, здесь можно изменить текст заголовка, выводимый формат "DisplayFormat" (это как раз то, что вам нужно, измените его на ####0.0) и пр. [001279]


Delphi 3

Получение данных DBGrid прежде, чем они будут отправлены: как мне узнать, что пользователь вводит в DBGrid?

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

procedure TForm1.DBGrid1KeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
var
B: byte;

begin
for B := 0 to DBGrid1.ControlCount - 1 do
if DBGrid1.Controls[B] is TInPlaceEdit then
begin
with DBGrid1.Controls[B] as TInPlaceEdit do
begin
Label1.Caption := 'Текст = ' + Text;
end;
end;
end;

[001285]


Хочу шапку в TDBGrid. Как сделать?

Nomadic советует:

Уже реализовано в виде вот этого компонента - © Andre

unit bdbgrid;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, Math;

type
TOnDrawTitleEvent = procedure(ACol : integer; ARect : TRect; var TitleText : string) of object;

TBitDBGrid = class(TDBGrid)
private
FBitmapBrowse : TBitmap;
FBitmapEdit : TBitmap;
FBitmapInsert : TBitmap;
FBitmapFill : TBitmap;
FRealTitleFont : TFont;
FOnDrawTitle : TOnDrawTitleEvent;
FResizeFlag : boolean;
{ Private declarations }
procedure SetRealTitleFont(Value : TFont);
procedure UpdateTitlesHeight;
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{ Protected declarations }
public
constructor Create(AOwner : TComponent);override;
destructor Destroy; override;
{ Public declarations }
published
property OnDrawTitle : TOnDrawTitleEvent read FOnDrawTitle write FOnDrawTitle;
property RealTitleFont : TFont read FRealTitleFont write SetRealTitleFont;
{ Published declarations }
end;

procedure Register;

implementation

var
DrawBitmap : TBitmap;

function Max(X, Y: Integer): Integer;
begin
 Result := Y;
if X > Y then Result := X;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text: string; Alignment: TAlignment);
// © Borland function :)
const
AlignFlags : array [TAlignment] of Integer =
( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
var
B, R: TRect;
I, Left: Integer;
begin
with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
begin { brush origin tics in painting / scrolling. }
Width := Max(Width, Right - Left);
Height := Max(Height, Bottom - Top);
R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
B := Rect(0, 0, Right - Left, Bottom - Top);
end;
with DrawBitmap.Canvas do
begin
DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
Font := ACanvas.Font;
Font.Color := ACanvas.Font.Color;
Brush := ACanvas.Brush;
SetBkMode(Handle, TRANSPARENT);
DrawText(Handle, PChar(Text), Length(Text), R,
AlignFlags[Alignment]);
end;
ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;

constructor TBitDBGrid.Create(AOwner : TComponent);
begin
inherited Create(Aowner);
FRealTitleFont := TFont.Create;
FResizeFlag := false;
end;

destructor TBitDBGrid.Destroy;
begin
 FRealTitleFont.Free;
inherited Destroy;
end;

procedure TBitDBGrid.UpdateTitlesHeight;
var
Loop : integer;
MaxTextHeight : integer;
RRect : TRect;
begin
MaxTextHeight := 0;
for loop := 0 to Columns.Count - 1 do
begin
RRect := CellRect(0, 0);
RRect.Right := Columns[Loop].Width;
RRect.Left := 0;
Canvas.Font := RealTitleFont;
MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,
PChar(Columns[Loop].Title.Caption),
Length(Columns[Loop].Title.Caption), RRect,
DT_CALCRECT + DT_WORDBREAK)
);
end;
if TitleFont.Height <> - MaxTextHeight then
TitleFont.Height := - MaxTextHeight;
end;

procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if MouseCoord(X, Y).Y = 0 then
FResizeFlag := true;
inherited MouseDown(Button, Shift, X, Y);
end;

procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if FResizeFlag then begin
FResizeFlag := false;
UpdateTitlesHeight;
end;
end;

procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
Indicator : TBitmap;
TitleText : string;
Al : TAlignment;
begin
if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol <> 0))) then
inherited DrawCell(ACol, ARow, ARect, AState)
else
begin
if DefaultDrawing then
begin DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
InflateRect(ARect, -1, -1);
Canvas.Brush.Color := FixedColor;
Canvas.FillRect(ARect);
end;
TitleText := Columns[ACol - 1].Title.Caption;
if Assigned(OnDrawTitle) then OnDrawTitle(ACol, ARect, TitleText);
if DefaultDrawing and (TitleText <> '') then
begin
Canvas.Brush.Style := bsClear;
Canvas.Font := RealTitleFont;
if ACol > 0 then Al := Columns[ACol - 1].Title.Alignment
else Al := Columns[0].Title.DefaultAlignment;
WriteText(Canvas, ARect, 2, 2, TitleText, Al);
end;
end;
end;

procedure TBitDBGrid.SetRealTitleFont(Value : TFont);
begin
 FRealTitleFont.Assign(Value);
Repaint;
end;

procedure Register;
begin
RegisterComponents('Andre VCL', [TBitDBGrid]);
end;

initialization
DrawBitmap := TBitmap.Create;

finalization
DrawBitmap.Free;

end.

[001288]


Delphi 1

Несколько таблиц в одном TDBGrid

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

Для того, чтобы поместить данные из нескольких таблиц в один DBGrid, нужно воспользоваться объектом TQuery. На заметку: используйте TQuery в режиме только для чтения, если вы не можете обеспечить гарантию выполнения некоторых из его руководящих принципов, один из которых - данные могут быть получены только от одной таблицы. [001302]


Как сделать так, чтобы в DBGrid напротив некоторых строк можно было бы галочку поставить?

Nomadic советует:

Hу примерно тaк (лишнее мaло-мaло порезaл, больно много его, но идея виднa :) нa сервере - тaблицa Advertis.DB, первичный ключ ID - autoincrement. Ha локaльном диске - тaблицa Founds.DB, с полем Advertis: integer, по которому есть индекс, и tblFounds.IndexFieldNames = 'Advertis'.

Ha гриде:

=== cut ===

procedure TMainForm.dbgWorkDblClick(Sender: TObject);
begin
TriggerRowSelection;
end;

procedure TMainForm.TriggerRowSelection;
begin
if dmFile.AdvertisCount <> 0then
begin
with dmFile do if not tblFounds.FindKey([tblAdvertisID.Value]) then
begin
tblFounds.AppendRecord( [tblAdvertisID.Value] );

end
else
begin
tblFounds.Delete;
end;
dbgWork.Refresh;
end;
end;

procedure TMainForm.dbgWorkDrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
if DataCol = 0 then with dmFile, dbgWork.Canvas do
begin
FillRect(Rect); {clear the cell}
if tblFounds.FindKey( [tblAdvertisID.Value] ) then
begin
TextOut(Rect.Left, Rect.Top, '?');
end
else
begin
 TextOut(Rect.Left, Rect.Top, 'o');
end;
end;
end;

=== cut ===

Окaзывaется, я переопределял рисовaние гридa, a не вычислял поле. Hе помню точно, но кaжется, чтобы не перечитывaть тaблицу нa кaждый дaблклик, a толькоперерисовaть грид.

А колонкa для гaлки в гриде определялaсь тaк:

=== cut ===

with dmFile, dbgWork.Columns do
begin
BeginUpdate;
Clear;

{check mark}
nc := Add;
nc.Width := 14;
nc.Font.Name := 'Wingdings';
nc.Font.Size := 11;
nc.Alignment := taRightJustify;
nc.Title.Caption := 'y';
nc.Title.Font.Name := 'Wingdings';
nc.Title.Font.Size := 10;
nc.Title.Alignment := taCenter;

[skip определения остaльных колонок]

EndUpdate;
end;

=== cut ===

Вроде всё.

Hу, кaк нaпечaтaть/обрaботaть только помеченное, сaм рaзберёшься. У меня тaм нaкручено чего-то с фильтрaми, думaю, можно проще.

Что кaсaется других способов - можно вместо временной тaблицы попользовaть список, мaссив или in-memory table. [001320]


Как в TDBGrid pазpешить только опеpации UPDATE записей и запpетить INSERT/DELETE?

Nomadic советует:

А я делаю так.
На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange.
Ниже текст типичного обратчика -

if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then
DBGrid1.Options := DBGrid1.Options + goRowSelect
else
DBGrid1.Options := DBGrid1.Options - goRowSelect;

Дело в том, что если у Grid'а стоит опция goRowSelect, то из Grid'а невозможно добавить запись. Ну а когда програмно вызываешь редактирование или вставку, то курсор принимает обычный вид и все Ok.

Лучше использовать конструкцию "State in dsEditModes" [001334]


Delphi 1

Обновление TDBGrid после редактирования отдельной записи на отдельной форме

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

На странице 95 Database Application Developers Guide (руководство разработчиков приложений баз данных), поставляемое с Delphi, приведен демонстрационный проект с двумя формами, демонстрирующий хорошую технику при использовании ttable на мастер-форме в качестве набора данных для детали.

Одним из решений вашей проблемы может служить связывание компонента DataSource на Form2 с набором данных DataSet на Form1. Это может быть достигнуто путем добавления следующей строки в обработчик события OnActivate для Form2:

MyDataSource.DataSet := Form1.MyTable;

Данный метод имеет 3 преимущества:

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

  2. если вам нужно определить установки для ваших полей таблицы, например, DisplayFormat или EditMask, вам нужно сделать это только один раз в таблице на Form1, вам не нужно это делать на каждой форме, которая использует таблицу;

  3. это сохраняет ресурсы и повышает производительность, поскольку ваше приложение при работе с таблицей использует только одну сессию. Тем не менее, в проектном времени вам нужно иметь TTable на вашей Form2 для того, чтобы вы могли выбрать поля для БД-контролов, после чего вы можете удалить TTable.
[001335]


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

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

используйте <имя поля>.index := <желаемый номер поля> [001339]


В Delphi 3 и выше ползунок TDBGrid иногда может находится не только в трех фиксированных позициях. Что для этого нужно?

Nomadic отвечает:

Здесь отрывки из исходников VCL -

unit DBGrids;

procedure TCustomDBGrid.UpdateScrollBar;
var
SIOld, SINew: TScrollInfo;
begin

[skipped]
if IsSequenced then
begin
SINew.nMin := 1;
SINew.nPage := Self.VisibleRowCount;
SINew.nMax := RecordCount + SINew.nPage -1;
if State in [dsInactive, dsBrowse, dsEdit] then
SINew.nPos := RecNo; // else keep old pos
end
else
begin
SINew.nMin := 0;
SINew.nPage := 0;
SINew.nMax := 4;
if BOF then SINew.nPos := 0
else if EOF then SINew.nPos := 4
else SINew.nPos := 2;
end;

[skipped]

unit dbtables;

function TBDEDataSet.IsSequenced: Boolean;
begin
Result := (FRecNoStatus = rnParadox) and (not Filtered); end;

То есть, к примеру, все будет работать "красиво" на таблицах BDE, если они:

  • таблицы Paradox;
  • на них не установлен фильтр.
TClientDataSet в режиме single-tier (briefcase) также работает "красиво". [001340]


Delphi 1

Изменение месторасположение колонок в TDBGrid

Var
i          : Integer ;
fName       : string ;
............ { Определение изменения месторасположения колонок }
............
with DBGrid1.DataSource.DataSet as TTable do
for i := 0 to IndexDefs.Count - 1 do begin
fName := DBGrid1.Fields[0].FieldName ;
if Copy( IndexDefs[i].Fields, 1, Length( fName ) ) = fName then
IndexName := IndexDefs[i].Name
end ;

[001341]


Решение проблемы передачи фокуса TDBGrid

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

Относится ко всем версиям Delphi

Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows."

unit FixedDBGrid;

interface

uses
Winprocs,wintypes, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, Grids, DBGrids;

type
TFixedDBGrid = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
procedure WMRButtonDown(var Message: TWMRButtonDown); message
WM_RBUTTONDOWN;
procedure WMLButtonDown(var Message: TWMLButtonDown); message
WM_LBUTTONDOWN;
published
{ Published declarations }
end;

procedure Register;

implementation

procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown);
begin
winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
inherited;
end;
procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin
winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
inherited;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFixedDBGrid]);
end;

end.

[001342]


Как отучить TDBGrid от автодобавления новой записи?

Добавьте в обработчик события вашего TTable "BeforeInsert" следующую строку:

procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset);
begin
Abort;  <<---эту строчку
end;

Осуществляем перехват нажатия клавиши и проверку на конец файла (end-of-file):

procedure TForm8.DBGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_DOWN) then
begin
TTable1.DisableControls ;
TTable1Next ;
if TTable1.EOF then
Key := 0
else
TTable1.Prior ;
TTable1.EnableControls ;
end ;
end;

[001364]


Delphi 2

Две таблицы в одном TDBGrid

Если у вас D2, вы можете воспользоваться свойством Lookup. Для этого выберите в контекстном меню объекта table редактор полей (fields editor). Затем для добавления нового поля нажмите <Ctrl>+N. Просто раскройте combobox и выберите lookup-поле. TDBGrid автоматически создаст выпадающий список, в котором пользователь сможет выбрать нужный элемент. [001378]


Delphi 1

Добавление к TDBGrid события OnClick

TGroothuisGrid = class(TDBGrid) {!}
published
property OnClick;
end;

Это все! OnClick уже объявлен в TControl как защищенное свойство. Все, что вы должны сделать, это опубликовать это свойство в компоненте-наследнике, зарегистрировать его (смотри гл. 8 Руководства по созданию компонентов, Component Writer's Guide) и использовать взамен TDBGrid. [001455]


Delphi 1

Позиция ячейки в TDBGrid

В TCustomGrid определен метод CellRect, который, к сожалению, защищен. Это означает, что даный метод доступен только для TCustomGrid и его наследников. Но все-таки существует немного мудреное решение вызова данного метода:

type
TMyDBGrid = class(TDBGrid)
public
function CellRect(ACol, ARow: Longint): TRect;
end;

function TMyDBGrid.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;

Вы можете сделать приведение типа вашего DBGrid к TMyDBGrid (это возможно, поскольку CellRect статический метод) и вызвать CellRect:

Rectangle := TMyDBGrid(SomeDBGrid).CellRect(SomeColumn, SomeRow);

procedure TfmLoadIn.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
const
Disp = 2;        //Правильно выравниваем компонент
begin
inherited;
if (gdFocused in State) then begin
if (Column.FieldName = 'TYPEDescription') then begin
dlTYPEDescription.Left := Rect.Left + DBGrid1.Left + Disp;
dlTYPEDescription.Top := Rect.Top + DBGrid1.top + Disp;
dlTYPEDescription.Width := Rect.Right - Rect.Left;
dlTYPEDescription.Height := Rect.Bottom - Rect.Top;
dlTYPEDescription.Visible := True;
end;
end;
end;

[001464]


Delphi 1

Dbgrid с цветными ячейками VI

Установите defaultDrawing в false, и создайте собственный onDrawDataCell, в котором и задавайте нужный вам цвет ячеек. Примерно так:

procedure Tform1.DBgrid1DrawDataCell
(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState);
begin
{ выберите цвет для текста (font.color) и фона (brush.color) }
if (field = table1Status) then begin  { белый на красном }
DBgrid1.canvas.font.color := clWhite;
DBgrid1.canvas.brush.color := clRed;
end
else begin  { черное на белом }
DBgrid1.canvas.brush.color := clWhite;
DBgrid1.canvas.font.color := clBlack;
end;

{ рисуем ячейку }
DBgrid1.canvas.textrect
(rect,rect.left+2,rect.top+2,field.asString);
end;

procedure TMainForm.CharGridDrawCell(Sender: TObject;
Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var
TheText: string;
begin
TheText := CharGrid.Cells[Col, Row];
with CharGrid.Canvas do
begin
{ Определяем цвет фона в зависимости от состояния ячейки: }
if gdFocused in State then
Brush.Color := clYellow          {Цвет ячейки с фокусом}
else if gdSelected in State then
Brush.Color := clOlive         {Цвет выбранной ячейки}
else {ячейка не имеет фокуса и не выбрана}
if IntFromStr(TheText) <> 0 then
Brush.Color := clNavy      {Цвет фона подсвеченной ячейки}
else
Brush.Color := clWhite;         {Цвет фона нормальной ячейки}
{ Определяем цвет текста: }
if IntFromStr(TheText) <> 0 then
Font.Color := clRed          {Цвет текста подсвеченной ячейки}
else
Font.Color := clNavy;             {Цвет текста нормальной ячейки}
TextRect(Rect, Rect.Left + 2, Rect.Top + 2, TheText);
end; {with CharGrid.Canvas}
end;

[001501]


Delphi 1

Показ Memo-поля в Dbgrid

...я все же лелею надежду, что когда-нибудь увижу TMemoField.DataSize, имеющим значение, отличное от нуля. Может быть значение DataSize является размером части Memo, которая сохранилась в .db-файле? Вместо этого я теперь пользуюсь объектом TBlobStream, который вполне хорошо справляется с этой работой. Все это у меня происходит примерно так:

Var
pBuffer  : PChar ;
Blob  : TBlobStream ;
begin
{FDataField - это TMemoField}
Blob := TBlobStream.Create( FDataField, bmRead ) ;
try
if Blob.Size > 0 then
try
GetMem( pBuffer, Blob.Size ) ;
Blob.Read( pBuffer^, Blob.Size ) ;
{                        что-то тут делаем    }
FreeMem( pBuffer, Blob.Size ) ;
except
ShowMessage( 'Нехватка памяти' );
end ;
finally
Blob.Free
end ;

[001505]


Как определить изменение фокуса строки в TDBGrid?

Используйте событие OnDataChange объекта Datasource, соединенного с DBGrid. Если параметр State в обработчике событие равен dsBrowse, значит вы перешли в новую строку (или только что открыли таблицу).

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

Я не уверен в том, что проблему можно решить, обрабатывая событие одинарного щелчка, для отслеживания события изменения строк я рекомендую использовать событие TDatasource.OnDataChange, а для колонок - TDBGrid.OnColEnter/Exit.

Лично я пользуюсь следующей рабочей технологией:

  1. Для того, чтобы обнаружить изменения текущей строки, воспользуйтесь событием TDataSource OnDataChange. OnDataChange возникает при прокрутке или щелчке на другой строке. Обработчик события может выглядеть приблизительно так:

    procedure Form1.DSrc1DataChange(Sender: TObject; Field: TField);

    где Field является колонкой, где произошло изменение.

    Поля TTable могут использоваться для сравнения текущих выбранных строк полей (ключ) с вашими требованиями. С той же целью может быть использовано и свойство TDBGrid Fields. Для примера:

    if tbl1.Fields[0].AsString = 'BlaBlaBla' then ...

    или

    if dbGrid1.Fields[I].IsNull then ...

  2. Для отслеживания изменения колонки, используйте события TDBGrid OnColExit & OnColEnter. Для определения выбранной к настоящему времени колонки воспользуйтесь свойствами TDBGrid SelectedField и SelectedIndex.

    Когда выбирается другая колонка другой строки, вы получаете события OnColExit, OnColEnter и OnDataChange.

  3. Можно пойти и "кривым" путем, взявшись за обработку события TDBGrid OnDrawDataCell, которое возникает когда ячейка выбирается, или когда сетка скроллируется. Обработчик события может выглядеть примерно так:

    procedure Form1.dbGrid1DrawDataCell(Sender: TObject; Rect: TRect;
    Field: TField; State: TGridDrawState);

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

  4. Если у вас нет проблем в создании "101 изменения" стандартных компонентов - что является проблемой для меня 8-), то попробуйте это. Это легко.

    Чтобы иметь доступ к индексу строки или колонки выбранной ячейки, вы должны унаследовать ваш класс от TCustomGrid и опубликать свойства времени выполнения Row и Col (текущие строка и колонка сетки, не таблицы!!):

    type
    TSampleDBGrid = class(TCustomGrid)
    public
    property Col;
    property Row;
    end;

    в соответствующей процедуре или обработчике события осуществите приведение типа:

    var
    G: TSampleDBGrid;
    begin
    G := TSampleDBGrid(myDBGrid1);
    if G.Row = I then ...
    if G.Col = J then ...

    Дело в том, что TDBGrid является потомком TCustomGrid, который имеет несколько свойств, содержащих координаты сетки, но это не опубликовано в TDBGrid.

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

grid.colcount := dbGrid.fieldcount;
table.first;
row := 0;
while not table.eof do begin
grid.rowcount := row + 1;
for i := 0 to grid.colcount-1 do
grid.cells[i,row] := dbGrid.fields[i].asString;
table.next;
inc (row);
end;

Могут быть ошибки, но это должно помочь.

Посмотрите на следующий код, он может вам помочь. Он берет у элемента управления свойсто 'Name' и помещает его в свойство 'Caption' метки.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Label1: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Edit2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Label1.Caption := TEdit(Sender).Name;
end;

procedure TForm1.Edit2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Label1.Caption := TEdit(Sender).Name;
end;

end.

[001528]


Delphi 1

Включение ComboBox в TDBGrid

Вот основные шаги чтобы сделать это:

  1. Создавайте и рисуйте TComboBox (CB) при получении ввода ячейки необходимой колонки табличной сетки
  2. Получайте текущее значение поля (если имеется) и помещайте его в CB
  3. После всех манипуляций, поместите новое значение обратно в поле
  4. Избавляемся от CB
[001540]


Delphi 1

TDBGrid и вертикальная полоса прокрутки I

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

Если у вас есть исходный код компонента, можно унаследоваться от него и создать свое поведение... [001613]


Delphi 1

TDBGrid и вертикальная полоса прокрутки II

...что ж, и да, и нет. Проблема неверного позиционирования полосы прокрутки заключается в том, что не все форматы данных (фактически никто) имеют поддержку порядковых номеров записей. Другими словами, в таблице не существует уникального идентификатора, определяющего в каком месте таблицы должна быть расположена запись. Например, в таблицах dBase записи имеют recNo, основанный на порядке их ввода. Если вы построите индекс на основе этого поля, то увидите, что все числа не имеют ничего общего с нумерацией. С другой стороны, SQL-таблицы и запросы никогда не слышали о порядке записей, да и этого никогда не будет. Таблицы Paradox единственные, которые включают логический порядок сортировки номеров в каждом индексе, который они создают. По какой-то, сугубо внутренней причине, Borland выбрал такое поведение вертикальной полосы прокрутки, которое не зависит от того, используете вы таблицы Paradox, или нет. Вы можете обойти это, выключив интегрированные полоски прокрутки и используя вместо них компонент TScrollBar, тем самым позволяя задать его поведение таким, каким вы его хотите видеть. [001638]


Delphi 1

Предустановка DBLookupComboBox

Вы можете редактировать ваш источник данных. Говорят, вы хотите сохранить ваши lookuping-данные из таблицы customer в таблицу sales - 'Cust No'? Вы можете просто проинициализировать поля (задать значение по умолчанию), редактируя таблицу sales "Cust No"

with tbSales do
begin
Edit;
FieldByName('Cust No').AsInteger := 1;
Post;
end;

[001319]


Delphi 1

Сортировка DBLookupComboBox по вторичному индексу

Одним из способов вывести выши данные в другом порядке сортировки является использование TQuery и включение в SQL-запрос ключевого слова "order by". После чего вы можете установить этот запрос как DataSource в вашем DBLookupComboBox.

ПРИМЕР:

Если у вас имеется таблица Customer, содержащая "Customer_No" и "Customer_Name", и индексированная по Customer_No, то ваш запрос должен содержать в редакторе списка строк (свойство SQL) для вашего TQuery следующую строку:

  select Customer_No, Customer_Name from Customer
     order by Customer_Name
[001350]


Значение DBLookupComboBox

Я думаю что у меня есть то, что вы хотите. Если вы обратитесь к свойству LookUpValue, то вы получите поле, которое .... ищете.

Я надеюсь что помог вам.

unit clookup;

interface

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

type
TDBJustLookupCombo = class(TDBLookupCombo)
private
{ Private declarations }
protected
{ Protected declarations }
function GetLValue: TField;
public
{ Public declarations }
property LookUpValue: TField read GetLValue;
published
{ Published declarations }
end;

TDBJustLookupList = class(TDBLookupList)
private
{ Private declarations }
protected
{ Protected declarations }
function GetLValue: TField;
public
{ Public declarations }
property LookUpValue: TField read GetLValue;
published
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Data Controls', [TDBJustLookupList,
TDBJustLookupCombo]);
end;

function TDBJustLookupCombo.GetLValue: TField;
begin
Result := LookupSource.DataSet.FieldByName(LookUpField);
end;

function TDBJustLookupList.GetLValue: TField;
begin
Result := LookupSource.DataSet.FieldByName(LookUpField);
end;

end.

[001380]


Delphi 2

Две колонки в DBLookupComboBox

Попробуйте использовать что-то типа этого:

DBLookupCombo1.LookupDisplay := 'Company;City;Country';

Т.е., для того, чтобы выводить более одного поля, разделите имя каждого поля точкой с запятой. [001632]


Delphi 1

Копирование содержимого DBMemo в DBMemo другого поля

Попробуй:

DBMemo6.Lines:=DBMemo5.Lines.Assign;

[001231]


Delphi 1

Поиск текста в DBMemo

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

procedure TMainForm.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:= DBMemo1.GetTextLen + 1;
GetMem(Buff,BuffLen);
DBMemo1.GetTextBuf(Buff,BuffLen);
P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength;
P:= StrPos(P, FT);
if P = NIL then MessageBeep(0)
else
begin
DBMemo1.SelStart:= P - Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
end;
end;

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

begin
DBMemo1.SelStart:= P - Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
DBMemo1.SetFocus;
end;

[001344]


Настройки всплывающих подсказок в DBNavigator во время выполнения приложения

Возможно ли изменение свойства Hints компонента TDBNavigator во время выполнения программы?

Это должно работать:

procedure TForm1.Button1Click(Sender: TObject);
var
ix : integer;
begin
With DBNavigator1 do
for ix := 0 to ControlCount - 1 do
if Controls[ix] is TNavButton then
with Controls[ix] as TNavButton do
case index of
nbFirst : Hint := 'Подсказка для кнопки First';
nbPrior : Hint := 'Подсказка для кнопки Prior';
nbNext : Hint := 'Подсказка для кнопки Next';
nbLast : Hint := '';
{......}
end;
end;

- Freddy Hansson [001008]


Delphi 1

Выключение кнопок в DBNavigator

{ Расширение DBNavigator: позволяет разработчику включать и выключать
отдельные кнопки через методы EnableButton и DisableButton }

unit GNav;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, DBCtrls;

type
TMyNavigator = class(TDBNavigator)
public
procedure EnableButton(Btn : TNavigateBtn) ;
procedure DisableButton(Btn : TNavigateBtn) ;
end;

procedure Register;

implementation

procedure TMyNavigator.EnableButton(Btn : TNavigateBtn) ;
begin
Buttons[Btn].Enabled := True ;
end ;

procedure TMyNavigator.DisableButton(Btn : TNavigateBtn) ;
begin
Buttons[Btn].Enabled := False ;
end ;

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

end.

[001165]


Delphi 1

Работа в коде с кнопками DBNavigator

Я думаю вам поможет следующий пример (взят из электронной справки по DELPHI), показывающий код нажатой кнопки. Я видел пару вопросов о том, как изменять кнопки навигатора в зависимости от состояния редактируемой вами записи. Если вам необходимо подтверждение действий пользователя, то необходимо каким-то образом организовать дополнительный перехватчик. Как это сделать, я, честно говоря, еще не думал.

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

Следующий код определяет нажатую кнопку навигатора и выводит сообщение с ее именем.

procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var
BtnName: string;
begin
case Button of
nbFirst  : BtnName := 'nbFirst';
nbPrior  : BtnName := 'nbPrior';
nbNext   : BtnName := 'nbNext';
nbLast   : BtnName := 'nbLast';
nbInsert : BtnName := 'nbInsert';
nbDelete : BtnName := 'nbDelete';
nbEdit   : BtnName := 'nbEdit';
nbPost   : BtnName := 'nbPost';
nbCancel : BtnName := 'nbCancel';
nbRefresh: BtnName := 'nbRefresh';
end;
MessageDlg('Была нажата кнопка' + BtnName, mtInformation, [mbOK], 0);
end;

[001229]


Delphi 1

Drag and Drop: как использовать ITEMATPOS для получения элемента DIRLISTBOX?

Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:

FDragItem:= ItematPos(X, Y, True);
if FDragItem >= 0 then
BeginDrag(false);

...

procedure TForm1.ListBoxDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if Source is TDirectoryListBox then
ListBox.Items.Add(TDirectoryListBox(Source).GetItemPath(FDragItem));
end;

[001664]


Delphi 1

Денежное поле редактирования

unit CurrEdit;

interface

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

type
TCurrencyEdit = class(TCustomMemo)
private
DispFormat: string;
FieldValue: Extended;
procedure SetFormat(A: string);
procedure SetFieldValue(A: Extended);
procedure CMEnter(var Message: TCMEnter);           message CM_ENTER;
procedure CMExit(var Message: TCMExit);             message CM_EXIT;
procedure FormatText;
procedure UnFormatText;
protected
procedure KeyPress(var Key: Char); override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property Alignment default taRightJustify;
property AutoSize default True;
property BorderStyle;
property Color;
property Ctl3D;
property DisplayFormat: string read DispFormat write SetFormat;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property Value: Extended read FieldValue write SetFieldValue;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Additional', [TCurrencyEdit]);
end;

constructor TCurrencyEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoSize := True;
Alignment := taRightJustify;
Width := 121;
Height := 25;
DispFormat := '$,0.00;($,0.00)';
FieldValue := 0.0;
AutoSelect := False;
WantReturns := False;
WordWrap := False;
FormatText;
end;

procedure TCurrencyEdit.SetFormat(A: String);
begin
if DispFormat <> A then
begin
DispFormat:= A;
FormatText;
end;
end;

procedure TCurrencyEdit.SetFieldValue(A: Extended);
begin
if FieldValue <> A then
begin
FieldValue := A;
FormatText;
end;
end;

procedure TCurrencyEdit.UnFormatText;
var
TmpText : String;
Tmp     : Byte;
IsNeg   : Boolean;
begin
IsNeg := (Pos('-',Text) > 0) or (Pos('(',Text) > 0);
TmpText := '';
For Tmp := 1 to Length(Text) do
if Text[Tmp] in ['0'..'9','.'] then
TmpText := TmpText + Text[Tmp];
try
FieldValue := StrToFloat(TmpText);
if IsNeg then FieldValue := -FieldValue;
except
MessageBeep(mb_IconAsterisk);
end;
end;

procedure TCurrencyEdit.FormatText;
begin
Text := FormatFloat(DispFormat,FieldValue);
end;

procedure TCurrencyEdit.CMEnter(var Message: TCMEnter);
begin
SelectAll;
inherited;
end;

procedure TCurrencyEdit.CMExit(var Message: TCMExit);
begin
UnformatText;
FormatText;
Inherited;
end;

procedure TCurrencyEdit.KeyPress(var Key: Char);
begin
if Not (Key in ['0'..'9','.','-']) Then Key := #0;
inherited KeyPress(Key);
end;

procedure TCurrencyEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
case Alignment of
taLeftJustify  : Params.Style := Params.Style or ES_LEFT and Not ES_MULTILINE;
taRightJustify : Params.Style := Params.Style or ES_RIGHT and Not ES_MULTILINE;
taCenter       : Params.Style := Params.Style or ES_CENTER and Not ES_MULTILINE;
end;
end;

end.

[001164]


Совет от читателя

Отслеживаем позицию курсора в EditBox

The_Sprite советует:

В форму добавляются TEditBox и TLabel, при этом TLabel постоянно показывает позицию курсора в элементе редактирования.

Совместимость: Все версии Delphi

Пример:

procedure TForm1.Edit1Change(Sender:
TObject);
begin
CurPos := Edit1.SelStart;
Label1.Caption := IntToStr(CurPos);
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
If Key = VK_LEFT then dec(CurPos);
if Key = VK_RIGHT then inc(CurPos);
Label1.Caption:= IntToStr(CurPos);
end;

[001541]


Числовая маска компонента Edit c помощью OnKeyPress III

Я предлагаю обработать событие OnKeyPress следующим образом:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if    NOT (Key in ('0'..'9', '.', #8, #13)) // разрешенные клавиши
OR (    (Key = '.')                  // пользователь нажал '.'
AND (POS ('.', Edit1.Text) > 0)) // десятичная точка уже имеется
then
begin
Key := #0;
MessageBeep (MB_OK);
end;
end;

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

Если вы не хотите связываться с десятичной дробью, уберите строчку с ключевым словом OR и символ '.' из первого IF-условия. Если вы хотите проверять, что пользователь ввел между LowLimit и HighLimit, воспользуйтесь следующим кодом:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if    NOT (Key in ('0'..'9', #8, #13))
OR (StrToInt (Edit1.Text + Key) < LowLimit)
OR (StrToInt (Edit1.Text + Key) > HighLimit)
then
begin
Key := #0;
MessageBeep (MB_OK);
end;
end;

[001555]


Delphi 1

Правое выравнивание текста в компоненте Edit

TEdit1  = class(TEdit)
public
procedure CreateParams(var Params: TCreateParams); Override;
end;

procedure TEdit1.CreateParams(var Params: TCreateParams); begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;

[001581]


Delphi 1

TEdit и событие OnEnter

interface

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

type
TNewComponent = class(TEdit)
private
{ Private declarations }
protected
{ Protected declarations }
procedure DoEnter; OverRide;
public
{ Public declarations }
constructor Create(AOwner: TComponent); OverRide;
destructor Destroy; Override;
published
{ Published declarations }
end;

procedure Register;

implementation

procedure TNewComponent.DoEnter;
begin
inherited DoEnter;
<нужный вам код>
end;

destructor TNewComponent.Destroy;
begin
inherited destroy;
end;

constructor TNewComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

end;

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

end.

[001615]


Письмо читателя

Как получить позицию курсора в TEdit?

Nomadic лаконично отвечает:

property SelStart: Integer;

[001716]


Рисование на GroupBox

Я хочу рисовать на холсте (Canvas) моего компонента GroupBox. Но когда я пробую рисовать на Component.Parent.Canvas, рисование происходит на форме, а не на моем компоненте GroupBox. Что я делаю неправильно?

Canvas - защищенное свойство TGroupBox и, поэтому, недоступное. Вы можете сделать его доступным следующим образом:

type TMyGroupBox = class(TGroupBox)
public
property Canvas;
end;

procedure SomeProcedure;
begin
...
with TMyGroupBox(GroupBox1).Canvas do
CopyRect(ClipRect, Image1.Canvas, ClipRect);
...
end;

- Ralph Friedman [001126]


Delphi 1

Доступ к компонентам GroupBox

Одно из свойств всех элементов управления - указатель на другие элементы, которые он содержит. Это свойство - свойство Controls, которое индексируется наподобие массива. Количество элементов управления содержится в свойстве ControlCount. Если вы хотите получить доступ к свойству или методу, которого нет у TControl, вам неоходимо осуществить приведение типа элемента списка.

procedure DoSomethingWithAGroupBox;
var
i : integer;
begin
with AGroupBox do
for i := 0 to ControlCount - 1 do
if controls[i] is TEdit then
TEdit(controls[i]).text := 'Как насчет этого?';
end;
end;

Приведенный выше пример будет работать, если элементом управления является TEdit или его наследник, например, TDBEdit или TMaskEdit. Все объекты могут быть приведены к типу одного из объектов, являющегося наследником базового типа (или им самим). Но не спешите приводить все к родительскому классу, родитель в данном случае здесь не подходит, поскольку он означает объект, который содержит сам себя. [001447]


Письмо читателя

Как сделать бегущую стpоку?
The_Sprite отвечает:

с помощью TLabel и TTimer. Пример:

procedure TForm1.Timer1Timer(Sender: TObject);
Const
LengthGoString = 10;
GoString = 'В конце стpоку желательно повтоpить,'+
' чтоб получить эффект кольцевого движения! В конце ст';
Const
i: Integer = 1;
begin
Label1.Caption:=Copy(GoString,i,LengthGoString);
Inc(i);
If Length(GoString)-LengthGoString < i then i:=1;
end;

[001534]


Delphi 1

SendMessage и TLabel
Вы не можете посылать сообщение элементу управления, не имеющему hWnd (т.е. свойство Handle в Delphi). Мне видится лучшим решением посылка сообщения невидимому элементу управления, который имеет дескриптор, и в его обработчике сообщения делать с Tlabel все, что вам заблагорассудится. [001588]


Навигация в ListBox при множественном выборе

Тема: Навигация в ListBox при множественном выборе

Данный пример выводит сообщение для каждого элемента Listbox, выбранного пользователем.

procedure TForm1.Button1Click(Sender: TObject);
var
Loop: Integer;
begin
for Loop := 0 to Listbox1.Items.Count - 1 do begin
if Listbox1.Selected[Loop] then
ShowMessage(Listbox1.Items.Strings[Loop]);
end;
end;

[001025]


Delphi 2

Внешние данные и ListBox

Мне необходимо создать Listbox с использованием внешних данных, хранимых в огромном (!) TStringList. Существует ли какое-нибудь системное сообщение, которое я мог бы перехватывать для получения данных Listbox из внешнего TStringlist?

Просматривая справочник по API, я нашел интересный пункт, который может помочь вам решить проблему: в Win32 вы можете создать Listbox со стилем LBS_NODATA:

(из описания CreateWindow:)

LBS_NODATA

Определяет ListBox со стилем no-data (без данных). Данный стиль необходимо применять в случае, если количество элементов в ListBox превышает одну тысячу. no-data ListBox также должен иметь стиль LBS_OWNERDRAWFIXED, но не может иметь стиль LBS_SORT или LBS_HASSTRINGS.

no-data ListBox похож на owner-drawn ListBox за исключением того, что он не содержит в своих элементах строк и изображений (иконок). Команды добавления, вставки или удаления данных в элементах такого типа ListBox будут проигнорированы, а запросы для поиска строк всегда будут заканчиваться неудачей. При необходимости отрисовки данного элемента, Windows посылает родительскому окну сообщение WM_DRAWITEM. Член itemID стуктуры DRAWITEMSTRUCT, передаваемой с сообщением WM_DRAWITEM, определяет номер строки (элемент), который должен быть перерисован. no-data ListBox не посылает сообщение WM_DELETEITEM.

Количество элементов в таком списке вы можете установить с помощью сообщения LB_SETCOUNT. Это позволит вам создать "виртуальный" ListBox с очень небольшой загрузкой.

Чтобы воспользоваться новым стилем, вам нужно создать новый класс-наследник от TListbox и перекрыть метод CreateParams.

- Peter Below [001038]


Инкрементальный поиск в ListBox II

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

Как это осуществить на Delphi?

Здесь придется немного воспользоваться Win API. Установите свойство формы KeyPreview в True и сделайте примерно следующее:

unit LbxSrch;

interface

uses
Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;

type
TFrmLbxSrch = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
ListBox1: TListBox;
Label1: TLabel;
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure ListBox1Enter(Sender: TObject);
private { Private declarations }
FPrefix: array[0..255] of char;
public
{ Public declarations }
end;

var
FrmLbxSrch: TFrmLbxSrch;

implementation

{$R *.DFM}

procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char);
{ Помните о том, что свойство KeyPreview должно быть установлено в True }
var
curKey: array[0..1] of char;
ndx:    integer;
begin
if ActiveControl = ListBox1 then begin
if key = #8 {Backspace (клавиша возврата)} then begin
if FPrefix[0] <> #0 then begin
FPrefix[StrLen(FPrefix) - 1] := #0;
end
end
else begin
curKey[0] := Key;
curKey[1] := #0;
StrCat(FPrefix, curKey);
ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING,
-1, longint(@FPrefix));
if ndx <> LB_ERR then
ListBox1.ItemIndex := ndx;
end;

Label1.Caption := StrPas(FPrefix);
Key := #0;
end;
end;

procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject);
begin
FPrefix[0] := #0;
Label1.Caption := StrPas(FPrefix);
end;

end.

- Ralph Friedman [001115]


Письмо читателя

Табуляция в графическом ListBox'е

Использование табуляции в ListBox'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение - использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"... Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:

procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
S, Ss: String;
P: Integer; // Флаг символа-разделителя
begin
begin
ListBox1.Canvas.FillRect(Rect);
//Отрисовка графики
...
//
S:=ListBox1.Items.Strings[Index];
P:=Pos('|', S);
If P=0 then
Ss:=S
else
Ss:=Copy(S, 1, P-1); // Если нет табуляции, то пишем всю строку, иначе отрезаем кусок до разделителя
ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss);
If P>0 then
ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P+1,
Length(S)-P+2));
end;
end;

Не забудьте перед запуском поставить нужное значение TabWidth.

Virtualik [001445]


Delphi 1

Выравнивание в ListBox'е

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

Например:

var
J, TempInt, LongPrefixLen, CurrPrefixLen: Integer;

begin
{Вычисляем TextWidth по ключевой строке}
{Устанавливаем CurrPrefixLen в TextWidth ключевого слова
строки Indexth}
LongPrefixLen := 0;
for J := 0 to ListBox1.Items.Count-1 do
with ListBox1.Canvas do
begin
TempInt:= TextWidth(Copy(Items[J],1,Pos(KeyString,Items[J]-1)));
if LongPrefixLen < TempInt then
LongPrefixLen:= TempInt;
if J = Index then
CurrPrefixLen:= TempInt;
end;
{PrevTextLeft - TextLeft = Где мы хотим вывести новый элемент}
TextOut(LongPrefixLen-CurrPrefixLen,Y,Items[I]);
end;

[001458]


Delphi 1

Создание ListBox во время выполнения программы

Установка выравнивания ListBox на alLeft вызывает изменение размеров ListBox при любом изменении размеров формы. Установка ширины происходит очень легко (помните о том, что ширина Width, которую вы видите в правой части строки, является свойством Width формы).

Количество элементов, хранимых ListBox, ограничено только доступной памятью.

procedure TForm1.CreateListBox;
var
LB : TListBox;
begin
LB := TListBox.Create;
LB.Align := alLeft;
LB.Width := Width div 2;
end;

Вот логика динамического создания ListBox и изменения его размера при изменения размеров формы. Я надеюсь, что помог вам. Также я подозреваю, что данные ListBox ограничены 32 килобайтами.

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs,
StdCtrls  { вам нужно это для ListBox }  ;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
listbox: TListBox ;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
listbox := TListBox.Create(self) ;
listbox.Parent := self ;
listbox.Top := 0 ;
listbox.Left := 0 ;
listbox.Width := self.Width div 2 ;
listbox.Height := self.Height div 2 ;
listbox.items.add('тест 1') ;
listbox.items.add('тест 2') ;
{ и т.д, и т.п. ... }
end;

procedure TForm1.FormResize(Sender: TObject);
begin
listbox.Width := self.Width div 2 ;
listbox.Height := self.Height div 2 ;
end;
end.

[001492]


Двойной ListBox

Я расположил на форме два компонента Listbox, и с помощью следующего кода заполнил один из них данными из таблицы:

tableName.Refresh;  {в вашем случае это может и не понадобится}
tableName.First;    {Убедимся, что мы смотрим первую запись}
while not tableName.Eof do {проходим в цикле таблицу}
begin
listbox1.items.add(tableName.FieldByName('USRID').AsString); {добавляем элемент в listbox1}
tableName.Next; {переходим к следующей записи}
end;

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

procedure TTemplateFrm.buildList(tableName: TTable; SelBox, AvailBox: TListBox);
begin
{в этой процедуре мы собираемся добавить данные в listbox'ы}
{получаем любые новые данные}
tableName.Refresh;
{Убедимся, что мы смотрим первую запись}
tableName.First;
{Теперь очищаем ListBox'ы}
SelBox.Clear;
AvailBox.Clear;
{Теперь добавляем элементы}
while not tableName.EOF do
begin
AvailBox.Items.Add(tableName.fieldByName('USRID').AsString +
' ' + tableName.fieldByName('DESCRIPTION').AsString);
tableName.Next;
end;
end;

Как перемещать данные между этими двумя списками? Если вы хотите использовать технологию "drag and drop" (перетащи и брось), то в обработчике mousedown вашей исходной таблицы воспользуйтесь процедурой begindrag:

if Button = mbLeft then
Tlistbox(sender).BeginDrag(false);

Затем, в вашем другом ListBox, для "опознания" и получения данных создайте следующий обработчик DragOver:

if Source = ListBox1 then
Accept := true
else
Accept := false;

Не используйте "Accept := (Source is TListbox)", как это показано в большинстве примеров. У вас имеется два компонента ListBox, следовательно, вам нужно сослаться на имя объекта, а не на его тип, а иначе программа просто не поймет кто есть кто.

Затем в обработчике dragDrop поместите следующий код, добавляющий данные в ListBox2 и удаляющий их из ListBox1.

Listbox2.Items.Add(Listbox1.Items[Listbox1.ItemIndex]);
Listbox1.Items.Delete(Listbox1.ItemIndex);

И, наконец, добавьте кнопку "Сохранить", если вы хотите сохранить содержимое ListBox2 в базе данных.

Я надеюсь, что это именно то, что вы искали, и что это окажется вам полезным. Если вы хотите также перемещать данные из ListBox2 в ListBox1, вам необходимо будет создать тот же код, но реверсировать его для получения в коде правильных ссылок на компоненты ListBox. [001507]


Delphi 1

ListBox - OnChange

Это было два месяца тому назад. Я нашел это на одном из Delphi-сайтов. Не очень сложно и понятно.

UNIT Lbox;

INTERFACE

USES
SysUtils, WinTypes, Messages, Classes, Controls, Graphics, Forms,
Menus, StdCtrls;

Type
TCngListBox = Class(TListBox)
private
FOnChange : TNotifyEvent;
FLastSel : integer;
procedure Click; override;
protected
procedure Change; Virtual;
published
property OnChange : TNotifyEvent read FOnChange write FOnChange;
public
constructor create(AOwner : TComponent); override;
End;

Procedure Register;

IMPLEMENTATION

procedure TCngListBox.Change;
begin
FLastSel := ItemIndex;
if assigned(FOnChange) then FOnChange(self);
end;

procedure TCngListBox.Click;
begin
inherited Click;
if FLastSel <> ItemIndex then
Change;
end;

constructor TCngListBox.Create;
begin
Inherited Create(AOwner);
FLastSel := -1;
end;

procedure Register;
begin
RegisterComponents('FreeWare',[TCngListBox]);
end;

END.

[001547]


Delphi 1

ListBox с графикой

Вот пример кода. Вам необходимо установить свойство ListBox Style в lbOwnerDrawFixed. Затем в обработчике события DrawItem мы попытаемся нарисовать изображение (смотри описание события OwnerDraw в справке по Delphi).

unit Listemas;

interface

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

type
TLTemas = class(TForm)
ListBox1: TListBox;
procedure FormActivate(Sender: TObject);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;

var
LTemas: TLTemas;

implementation

{$R *.DFM}

procedure TLTemas.FormActivate(Sender: TObject);
var
Dibujo: TIcon;
begin
with ListBox1.Items do
begin
Dibujo := TIcon.create;
Dibujo.LoadFromFile('.\ICO\justic.ico');
AddObject('Poder Legislativo y Partidos Politicos',Dibujo);
Dibujo := TIcon.create;
Dibujo.LoadFromFile('.\ICO\justic.ico');
AddObject('Poder Ejecutivo Nacional',Dibujo);
end;
end;

procedure TLTemas.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Icon: TIcon;
Offset: Integer;    { ширина отступа текста }
begin
with (Control as TListBox).Canvas do { рисуем на холсте элемента управления, не на форме }
begin
FillRect(Rect); { очищаем прямоугольник }
Offset := 2; { обеспечиваем отступ по умолчанию }
Icon := TIcon((Control as TListBox).Items.Objects[Index]); { получаем иконку для данного элемента }
if Icon <> nil then
begin
Draw(Rect.Left+1,Rect.Top+2,TIcon((Control as ListBox).Items.Objects[Index]));

Offset := Icon.width + 9; { добавляем четыре пикселя между иконкой и текстом }
end;
TextOut(Rect.Left + Offset, Rect.Top+7, (Control as TListBox).Items[Index]) { выводим текст }
end;
end;

end.

Воспользуйтесь событием OnDrawItem объекта ListBox (или ComboBox, или др.). В его обработчике рисовать графику так же легко, как и писать текст. (Полное управление вы получите после того, как подключите к своей работе обработку события OnMeasureItem)

procedure ListDrawItem(Control: TWinControl; Index:
Integer;
Rect: TRect; State: TOwnerDrawState);
var
BitMap : TBitMap;
begin
{Здесь инициализируем Bitmap.... например, загружаем в него изображение}

With (Control as TListBox).Canvas do
begin
FillRect(Rect);
Draw(Rect.Left, Rect.Top, BitMap);
TextOut(Rect.Left + 2 + BitMap.Width, Rect.Top,
DstList.items.strings[index]);  {DstList - имя списка}
end;

end;

[001548]


Delphi 1

Имя элемента ListBox

Воспользуйтесь свойствами Items и ItemIndex:

Foo := Bar.Items[Bar.ItemIndex];

Foo теперь должен содержать выбранный в ListBox элемент.

ShowMessage( Listbox1.Items[Listbox1.ItemIndex] );

[001566]


Delphi 1

Хранение переменных в ListBox

TListBox для хранения строк имеет собственный TStringList. TStringList имеет свойство items (или что-то типа этого), которое хранит указатели (или что-то еще, имеющее размер указателя или меньше). Так, например, вы можете хранить указатель на объект, компонент, запись или переменную соответственно в каждой строке TListBox. [001602]


Письмо читателя

Как добавить горизонтальную полосу прокрутки в TListBox?

Nomadic отвечает:

Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки. Полоска прокрутки появляется, когда окно списка слишком мало для показа всех элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки, когда какие-либо элементы списка имеют большую ширину, чем само окно списка. Конечно, есть возможность добавить горизонтальную полосу прокрутки. Добавьте следующий код в обработчик события OnCreate Вашей формы:

procedure TForm1.FormCreate(Sender: TObject);
var
i, MaxWidth: integer;
begin
MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;

Этот код находит ширину, в пикселах, самой длинной строки в окне списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна списка. [001610]


Как рисовать картинки в пунктах меню (через OwnerDraw)?

Nomadic советует:

Смотри пример:

unit DN_Win;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus, StdCtrls,

type
TDNForm = class(TForm)
MainMenu1: TMainMenu;
cm_MainExit: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure cm_MainExitClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
BM:TBitmap;
Procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
Procedure WMMeasureItem(var Msg:TWMMeasureItem); message wm_MeasureItem;
end;

var
DNForm : TDNForm;

implementation

{$R *.DFM}

var
Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);
begin
{картинку в меню}
yMenu:=GetSystemMetrics(SM_CYMENU);
comm:=cm_MainExit.Command;
ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}

procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
DNForm.Close;
end;{TDNForm.cmExitClick}

{для прорисовки меню}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
begin
if ItemID=comm then
begin
ItemWidth:=yMenu;
Itemheight:=yMenu;
end;
end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
MemDC:hDC;
BM:hBitMap;
mtd:longint;
Begin
with Msg.DrawItemStruct^ do
begin
if ItemID=comm then
begin
BM:=LoadBitMap(hInstance,'dver');
MemDC:=CreateCompatibleDC(hDC);{hDC входит в структуру TDrawItemStruct}
SelectObject(MemDC,BM);
{rcItem входит в структуру TDrawItemStruct}
if ItemState=ods_Selected then mtd:=NotSrcCopy else mtd:=SrcCopy;

StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);
DeleteDC(MemDC);
DeleteObject(BM);
end;
end{with}
End;{TDNForm.WMDrawItem}

end.

[001154]


Delphi 1

Элементы меню с правым выравниванием

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

Хитрость кроется в префиксе заголовка элемента меню, а именно в символе Backspace, т.е. Chr(8).

Я не смог это сделать во время разработки приложения, это нужно делать во время его работы (например, в процедуре FormCreate):

MenuName.Caption := Chr(8) + MenuName.Caption;

[001579]


Delphi 1

TMenuItem - создание и добавление событий во время работы приложения

Вы можете заполнить меню следующим образом:

...
ppmProgram: TMenuItem;
Private
procedure PopulateMenu(Sender: TObject);
procedure NewShortcutClick(Sender: TObject);
...

procedure TForm1.PopulateMenu(Sender: TObject);
var
ppmAddNewShortcut : TMenuItem;
begin
ppmAddNewShortcut         := TMenuItem.Create(Self);
ppmAddNewShortcut.Caption := '&Тест';
ppmAddNewShortcut.OnClick := NewShortcutClick;
ppmProgram.Add(ppmAddNewShortcut);
end;

procedure TForm1.NewShortcutClick(Sender: TObject);
begin
{ Здесь введите код для "Тест" }
end;

[001623]


С картинками!

Исправление иконок выключенных пунктов меню

VS пишет:

При использовании ListImage, в недоступных пунктах Menu пиктограммы отображаются некорректно. Это можно видеть на рисунке:

Ошибка связана с получением монохромного изображения в процедуре TCustomImageList.DoDraw. Однако ее можно исправить, если воспользоваться небольшой "заплаткой" - ScrambleBitmap.

procedure TCustomImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);

procedure ScrambleBitmap(var BMP: TBitmap);
const
RMask = $0000FF;
RAMask = $FFFF00;
GMask = $00FF00;
GAMask = $FF00FF;
BMask = $FF0000;
BAMask = $00FFFF;
var
R,C: integer;
Color: LongWord;
begin
with Bmp.Canvas do begin
for C:= 0 to Bmp.Height - 1 do
for R:= 0 to Bmp.Width - 1 do begin
Color:= Pixels[R,C];
if ((Color = 0) or (Color = $FFFFFF)) then Continue;
if (((Color and RMask > $7F) and (Color and RAMask > $0)) or
((Color and GMask > $7F00) and (Color and GAMask > $0)) or
((Color and BMask > $7F000) and (Color and BAMask > $0))) then
Pixels[R,C]:= $FFFFFF
else
Pixels[R,C]:= 0;
end;
end;
end;

const
ROP_DSPDxax = $00E20746;
var
R: TRect;
DestDC, SrcDC: HDC;
begin

if HandleAllocated then begin
if Enabled then
ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
GetRGBColor(BkColor), GetRGBColor(BlendColor), Style)
else begin
if FMonoBitmap = nil then begin
FMonoBitmap:= TBitmap.Create;
with FMonoBitmap do begin
// Monochrome:= True; закомментировать!!!
Width:= Self.Width;
Height:= Self.Height;
end;
end;
{ Store masked version of image temporarily in FBitmap }
FMonoBitmap.Canvas.Brush.Color:= clWhite;
FMonoBitmap.Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
ImageList_DrawEx(Handle, Index, FMonoBitmap.Canvas.Handle, 0,0,0,0,
CLR_DEFAULT, 0, ILD_NORMAL);
ScrambleBitmap(FMonoBitmap); // заплатка
R:= Rect(X, Y, X+Width, Y+Height);
SrcDC:= FMonoBitmap.Canvas.Handle;
BitBlt(SrcDC, 0, 0, Width, Height, SrcDC, 0, 0, DSTINVERT); // добавить!!!
{ Convert Black to clBtnHighlight }
Canvas.Brush.Color:= clBtnHighlight;
DestDC:= Canvas.Handle;
Windows.SetTextColor(DestDC, clWhite);
Windows.SetBkColor(DestDC, clBlack);
BitBlt(DestDC, X+1, Y+1, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
{ Convert Black to clBtnShadow }
Canvas.Brush.Color:= clBtnShadow;
DestDC:= Canvas.Handle;
Windows.SetTextColor(DestDC, clWhite);
Windows.SetBkColor(DestDC, clBlack);
BitBlt(DestDC, X, Y, Width, Height, SrcDC, 0, 0, ROP_DSPDxax);
end;
end;
end;

Теперь пиктограммы в Menu будут отображаться как на приведенном рисунке:

"Заплатку" можно использовать и в ToolBar, где ошибка аналогична. ToolBar без "заплатки":

ToolBar с "заплаткой":

[001637]


Delphi 1

Действие меню для нескольких форм

В вашей главной форме вам необходимо перехватывать нажатия клавиш и передавать их НЕ-MDI формам, вызывая их процедуры, т.е. идея заключается в неиспользовании обработчиков событий НЕ-MDI форм. Если такая идея вам нравится, то можно воспользоваться в главной форме событием onkeydown, где проверять нажатие пользователем ALT-комбинации клавиш прежде, чем будет вызвана процедура НЕ-MDI формы. Не забывайте вносить модули НЕ-MDI форм в список USES главной формы. Я надеюсь вы это уже сделали. Если изложенная выше идея вам не нравится, то единственный способ, который я знаю, заключается в передаче фокуса НЕ-MDI форме прежде, чем пользователь нажмет клавишу. [001769]


Совет читателя

Как проиграть AVI на полный экран?

Своим опытом делится Олег Кулабухов:

Просто проиграть его на другой форме, развернутой на весь экран

{Code for Form 1}

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Show;
Form2.WindowState := wsMaximized;
Form2.MediaPlayer1.Notify := false;
Form2.MediaPlayer1.Display := Form2.Panel1;
Form2.MediaPlayer1.FileName := 'C:\TheWall\DELCAR2.AVI';
Form2.MediaPlayer1.Open;
Form2.MediaPlayer1.DisplayRect := Form2.ClientRect;
Form2.MediaPlayer1.Play;
end;

{Code for Form 2}

procedure TForm2.MediaPlayer1Notify(Sender: TObject);
begin
if MediaPlayer1.NotifyValue = nvSuccessful then
Form2.Close;
end;

[001852]


Delphi 1

Получение данных из компонента Memo

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

procedure TForm1.SpeedButton1Click(Sender: TObject);

var
LineNo : integer;
ColNo  : integer;

begin
LineNo:=SendMessage(Memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0);
ColNo:=Memo1.SelStart;
if LineNo>0 then begin
While SendMessage(Memo1.Handle,EM_LINEFROMCHAR,ColNo,0)=LineNo do
ColNo:=ColNo-1;
ColNo:=Memo1.SelStart-ColNo-1;
end else
ColNo:=Memo1.SelStart;
Panel1.Caption:='Строка '+IntToStr(LineNo)+' ; Колонка '+IntToStr(ColNo);
{Здесь вы можете получить текст через Memo1.Lines[LineNo].Text[ColNo] ...}
end;

Предупреждение! Данный код был написан в среде WinNT/D2 с использованием элемента управления richedit. Я тестировал то же самое, но с компонентом Memo и в D1, но этот код я забыл дома. Код выше написан по памяти и не тестировался, но я думаю он должен работать. Если вы переберетесь на D2, измените вызов sendmessage на следующий:

SendMessage(Memo1.Handle,EM_EXLINEFROMCHAR,0,ColNo)

[001449]


Delphi 1

Изменение поведения Delete в компоненте Memo

Просто меняю обработчик Memo OnKeyDown следующим образом:

if Key = VK_DELETE then
begin
здесь делайте все, что вы хотите
end;
if Key = VK_BACK then
begin
аналогично
end;

Вероятно, лучшим решением было бы использование конструкции CASE, но я не уверен, что она поймет как нужно VK_??. Возможно, после обработки нужно вызвать унаследованный обработчик, т.е. дать поработать обработчику верхнего уровня, у которого мы стырили управление. Не хотите подумать над этим?

Чтобы понять, где мы сейчас находимся, используйте SelStart, например, так:

var
Lpos, Cpos : Integer;
Lpos := SendMessage(memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0);
Cpos := SendMessage(memo1.Handle,EM_LINEINDEX,Lpos,0);
CPos := Memo1.SelStart-CPos;

Ответ: поскольку VK_? имеет целочисленный тип, то это будет работать:

case Key of
VK_DELETE :
begin
Key := 0;  {этим мы не позволяем сообщению keydown передаваться дальше,
например, форме или компонентам}
выполняем нужный код;
end;
VK_BACK:
begin
Key := 0;  {этим мы не позволяем сообщению keydown передаваться дальше,
например, форме или компонентам}
выполняем нужный код;
end;
end;

[001468]


Delphi 1

Вставка текста в TMemo II

Используйте сообщение Windows API EM_REPLACESEL: (из справки по Windows API)

EM_REPLACESEL
wParam = 0;                               /* не используется, должен быть ноль */
lParam = (LPARAM) (LPCSTR) lpszReplace;   /* адрес новой строки */

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

lpszReplace содержит новый текст.
Параметр	Описание
lpszReplace	Значение lParam. Указатель на терминированную нулем строку,
                содержащую замещающий текст. { Указатель на строку }

Возвращаемое значение
Данное сообщение значение не возвращает.

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

В случае отсутствие выбранного текста, замещающий текст вставляется
в текущую позицию курсора.
Сделайте список с вашими стандартными фразами, и используйте события "OnClick" или "OnMouseDown" в комбинации с "Alt", "Shift" или "Ctrl". Пример: Когда пользователь нажимает клавишу "Alt" в комбинации с правой кнопкой мыши, выводится список заранее подготовленных фраз и выбранная вставляется в ваш TMemo-компонент.

Для вставки строки в Memo:

procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=0;
SelText:='Эта строка включается в Memo, начиная с 10-й позиции ';
end;
end;

Для вставки строки И замены некоторого существующего текста:

procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=20;
SelText:='Эта строка включается в Мемо, начиная с 10-й позиции и замещает собой 20 символов ';
end;
end;

Поместите текст, который вы хотите вставить, в переменную PChar, затем вставьте текст в Memo, используя команду SetSelTextBuf, где SelStart устанавливается в позицию курсора TMemo. Это классно работает ..

Другая полезность: вы можете обхойти предел TMemo в 32K в случае, если вы загружаете в него текст, пользуясь методом/командой Lines.LoadfromFile. Компонент имеет внутренний предел в 32K. Если вы загружаете нужный файл в указатель, и используете команду/метод SetTexBuf, то в этом случае в TMemo можно загрузить текста вплоть до 64K. [001544]


Delphi 1

Перемещение по Memo

procedure MemoCursorTo(Memo:TMemo; MemoLine, MemoCol: Integer);
begin
Memo.SelStart := SendMessage (Memo.Handle, EM_LINEINDEX, MemoLine, 0)
+ MemoCol - 1;
end;

[001562]


Delphi 2

Включение/Выключение закладки Notebook II

В обработчике события OnChange вашего TTabbedNotebook разместите код примерно такого содержания:

if (NewTab = 0) and (IWantToDisableTab0) then
AllowChange := False;

if (NewTab = 1) and (IWantToDisableTab1) then
AllowChange := False;

...

Да, можно использовать конструкцию Case, но If в данном случае я посчитал удобнее. [001529]


Delphi 1

Основные различия между TABSET у NOTEBOOK и TABBEDNOTEBOOK

На мой взгляд,

+ с Tabbed Notebook легче работать в режиме разработки благодаря тесной интеграции tabset и notebook
- Tabbed Notebook недостает возможности размещать закладки в нужном вам порядке

Возможно, существенным ограничением следует считать отсутствие исходников даже в полной поставке исходного кода VCL (VCL source kit), и невозможность изменения ориентации закладок, кроме их нижнего расположения, но все вышесказанное можно отнести к субъективному мнению.
Компоненты Orpheus VCL имеют "мультистраничную форму с закладками (tabbed multi-page form)" и позволяют использовать расширенные характеристики элемента управления.

C точки зрения использования ресурсов, оба элемента управления практически идентичны. Самое большое различие (кроме очевидного эстетического различия с точки зрения размещения закладок) в том, что в случае использования компонента TabbedNotebook все закладки видимы. При использовании комбинации Tabset и Notebook, вы имеете возможность горизонтальной прокрутки для показа невидимых в данный момент закладок (а-ля Палитра Компонентов). Предпочтений здесь нет, все зависит от ситуации. [001552]


Delphi 1

Раскрытие пути к элементу TOutline по его индексу

Когда я писал этот код, у меня была цель по индексу TOutlineNode (который являлся результатом поиска) раскрыть его путь (т.е. раскрыть дочерние узлы, ведующие к нему), не затрагивая при это остальные узлы.

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

Процедура подразумевает работу с объектом TOutline, имеющим имя Outline.

var
Outline: TOutline;

procedure TSearchDlg.ExpandPathToFoundItem(const FoundItemIndex: Longint);
{------------------------------------------------------------------------------
Открываем путь к данному элементу (элемент определяется номером индекса). До корневого элемента необходимо раскрывать только родителей.
-----------------------------------------------------------------------------}
var
ItemIndex:   Longint;
Found:       Boolean;
LastCh:      Longint;
Path:        String;
ItemText:    String;
SepPos:      Integer;
OldSep:      String;
begin
{Сохраняем старый ItemSpearator}
OldSep:=Outline.ItemSeparator;
{Устанавливаем новый ItemSeparator}
Outline.ItemSeparator:='\';
{Получаем полный путь к TOutlineNode и добавляем '\'.
Это делается для упрощения последующего алгоритма}
Path:=Outline.Items[FoundItemIndex].FullPath+'\';
{Зацикливаемся до тех пор, пока не будет достигнут конец пути}
while Length(Path) > 0 do begin
{Определяем в пути позицию первого '\'}
SepPos:=Pos('\',Path);
{Изолируем элемент TOutlineNode}
ItemText:=Copy(Path,1,SepPos-1);
{Определяем индекс TOutlineNode}
ItemIndex:=Outline.GetTextItem(ItemText);
{Раскрываем его}
Outline.Items[ItemIndex].Expand;
{Вырезаем из строки раскрытый TOutlineNode}
Path:=Copy(Path,SepPos+1,Length(Path)-SepPos+1);
end;
{Восстанавливаем оригинальный ItemSeparator}
Outline.ItemSeparator:=OldSep;
end;

Детали

Давайте присвоим элементу желаемый путь:

        "My Computer\Hardware\SoundCard\Base Adress"
На первом шаге возвращается приведенный выше путь. Затем изолируется подстрока "My Computer". Затем с помощью метода "GetTextItem" определяется индекс TOutlineNode "My Computer". Метод "Expand" раскрывает это дерево. Впоследствие "My Computer" вырезается из пути, и новым путем становится "Hardware\SoundCard\Base Adress".

Затем определяется индекс "Hardware", раскрывается, и снова выразается. Данная процедура повторяется до тех пор, пока не останется пути, который можно раскрыть. После чего полностью раскрывается путь передаваемой TOutlineNode. [001517]


Delphi 2

TOutline: Перетащи и брось I

Вам нужно перехватывать в TOutline сообщение wm_DropFiles. Для этого необходимо создать его потомка. Также, вы должны убедиться в том, что дескриптор TOutline Handle хотя бы раз передавался в качестве параметра функции DragAcceptFiles. Для определения положения мыши в момент перетаскивания используется DragQueryPoint. Если вы прочтете разделы в WINAPI.HLP по DragAcceptFiles, wm_DropFiles, DragQueryFile, DragQueryPoint и DragFinish, то вы поймете, как все это работает. [001659]


Delphi 1

TOutline: Перетащи и брось II

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

  1. Разрешите Windows как можно скорее обработатывать события мыши:

    OnMouseDown:
    BeginDrag(False);
    while ... do
    begin
    Application.ProccessMessages; { это позволяет Windows обработать }
    { все сообщения за один шаг }
    end;

    Комментарий:

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

  2. Аналогично:

    OnMouseDown:
    BeginDrag(False);
    Application.ProccessMessages;
    while ... do
    begin
    { единственный шаг обработки }
    end;

    Убедитесь в правильности работы кода.

  3. Переместите вызов BeginDrag в обработчик события OmMouseMove.
[001661]


Delphi 1

TOutline: Перетащи и брось III

Установите DragMode = dmManual, создайте OnMouseDownHandler, внутри обработчика осуществите вызов BeginDrag(False). BeginDrag(False) в действительности не начинает перемещение, пока пользователь не переместит объект больше, чем на 5 пикселей, так что если пользователь просто щелкнет на компоненте, операция перетаскивания даже не начнется. [001666]


Delphi 1

TOutline: чтение из файла

Если вы хотите сохранять TOutline, вам нужно обратить внимание на методы SaveToFile и ReadFromFile. Если же вы хотите создать ваш собственный файл (для хранения данных связанных с вашим TOutline), рекомендую воспользоваться TStream (или его потомком -> TFileStream).

У меня тоже были проблемы с хранением TOutline в своем файле. Для этой цели идеально подходит создание записи следующего вида:

TSaveNode=record
Text: String
Index: Longint;
Parent: Longint;
Data: Pointer
end;

Это вся информация об TOutLine, которую вам нужно сохранить. Вы можете сохранить ее, пройдясь в цикле через все узлы TOutlineNodes и записывая их в поток. Для загрузки всего файла читайте запись за записью и используйте метод TOutline.AddChild. TRecord при этом будет содержать всю необходимую информацию. [001719]


Delphi 2

Динамические PageControl/TabSheet I

Динамическое создание Page Control'ов и Tab Sheet'ов:

var
T : TTabSheet;
P : TPageControl;
begin
// Создаем PageControl
// При создании получаем ссылку на PageControl, чтобы в дальнейшем на него ссылаться.
P := TPageControl.Create(application);
with P do begin
Parent := Form1;  // устанавливаем его как элемент управления формы.
Top := 30;
Left := 30;
Width := 200;
Height := 150;
end;  // with TPageControl

// Создаем 3 страницы
T := TTabSheet.Create(P);
with T do begin
Visible := True;   // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 1';
PageControl := P;  // Назначаем Tab в Page Control
end;  // with

T := TTabSheet.Create(P);
with T do begin
Visible := True;   // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 2';
PageControl := P;  // Назначаем Tab в Page Control
end;  // with

T := TTabSheet.Create(P);
with T do begin
Visible := True;   // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 3';
PageControl := P;  // Назначаем Tab в Page Control
end;  // with

// Создаем 3 кнопки, 1 на страницу
with tbutton.create(application) do begin
Parent := P.Pages[0];  // "Указываем" кнопке родительскую страницу
Caption := 'Привет, страница 1';
Left := 0;
Top := 0;
end; // with

with tbutton.create(application) do begin
Parent := P.Pages[1];  // "Указываем" кнопке родительскую страницу
Caption := 'Привет, страница 2';
Left := 50;
Top := 50;
end; // with

with tbutton.create(application) do begin
Parent := P.Pages[2];  // "Указываем" кнопке родительскую страницу
Caption := 'Привет, страница 3';
Left := 100;
Top :=  90;
end; // with

// Это должно быть сделано, или Tab первоначально не синхронизируется
// с правильной страницей. Только в случае, если у вас более чем одна страница.
P.ActivePage := P.Pages[1];
P.ActivePage := P.Pages[0];  // Реально показываемая страница
end;

[001024]


Динамические PageControl/TabSheet II

В данном документе показана технология динамического добавления страниц компонента PageControl (объектов TTabSheet) к элементу управления Windows 95/NT PageControl (объект TPageControl). Оба этих объекта объявлены в модуле ComCtrls. Поэтому убедитесь в том, что ComCtrls указан в списке используемых модулей.

Как динамически создать PageControl

Прежде, чем мы приступим к динамическому созданию страниц, давайте динамически создадим PageControl (если он еще не на форме). Это делается посредством вызова конструктора TPageControl Create с параметром owner, равным Self. Конструктор Create возвращает объектную ссылку на вновь созданный объект PageControl и назначает его переменной 'PageControl'. Вторым шагом будет установка свойства PageControl Parent в Self. Свойство Parent определяет где должен быть отображен новый PageControl; в нашем случае это будет сама форма. Вот кусок кода, демонстрирующий вышесказанное:

var
PageControl : TPageControl;

PageControl := TPageControl.Create(Self);
PageControl.Parent := Self;

Примечание: При разрушении формы разрушаются также PageControl и ее закладки, поскольку они принадлежат форме.

Как динамически создавать закладки

Существует два основных способа добавления новых страниц к PageControl. Сначала вы должны динамически создать TTabSheet следующим образом:

var
TabSheet : TTabSheet;

TabSheet := TTabSheet.Create(Self);

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

TabSheet.Caption := 'Закладка 1';

И, наконец, самая важное действие заключается в том, что новой странице необходимо сообщить, какому объекту PageControl она принадлежит. Это делается с помощью присваивания свойством TTabSheet PageControl переменной-ссылки TPageControl, типа той, которую мы создали выше (PageControl). Вот кусок кода, демонстрирующий вышесказанное:

TabSheet.PageControl := PageControl;

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

Ключевым моментом при создании и размещении элемента управления на странице TabSheet является назначение свойства Parent на переменную-ссылку класса TTabSheet. Вот пример:

var
Button : TButton;

Button := TButton.Create(Self);
Button.Caption := 'Кнопка 1';
Button.Parent := TabSheet;

Более подробно об объектах TPageControl и TTabSheet вы можете узнать в онлайн-документации, или посмотреть код файла ComCtrls.pas, расположенного в вашем каталоге ..\Delphi 2.0\SOURCE\VCL.

Полный код примера

// Код использует форму с единственной на ней кнопкой.

unit DynamicTabSheetsUnit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure TestMethod(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses ComCtrls;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
PageControl : TPageControl;
TabSheet : TTabSheet;
begin
// Создаем PageControl
PageControl := TPageControl.Create(Self);
PageControl.Parent := Self;

// Создаем первую страницу и связываем ее с PageControl
TabSheet := TTabSheet.Create(Self);
TabSheet.Caption := 'Закладка 1';
TabSheet.PageControl := PageControl;

// Создаем первую страницу

with TButton.Create(Self) do
begin
Caption := 'Кнопка 1';
OnClick := TestMethod;  // Назначаем обработчик события
Parent := TabSheet;
end;

// Создаем вторую страницу и связываем ее с PageControl

TabSheet := TTabSheet.Create(Self);
TabSheet.Caption := ' Закладка 2';
TabSheet.PageControl := PageControl;
end;

procedure TForm1.TestMethod(Sender: TObject);
begin
ShowMessage('Привет');
end;

end.

[001531]


Delphi 2

Клавиши-акселераторы для TPageControl

Тема: Создание акселераторов, работающих с TPageControl

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

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

unit tapage;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;

type

TAPageControl = class(TPageControl)
private
procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
end;

procedure Register;

implementation

procedure TAPageControl.CMDialogChar(var Msg: TCMDialogChar);
var
i: Integer;
S: String;
begin
if Enabled then
for I := 0 to PageCount - 1 do
if IsAccel(Msg.CharCode, Pages[i].Caption) and
Pages[I].TabVisible then begin
Msg.Result := 1;
ActivePage := Pages[I];
Change;
Exit; // выход из цикла.
end;
inherited;
end;

procedure Register;
begin
RegisterComponents('Test', [TAPageControl]);
end;

end.

[001028]


Delphi 1

Создание панелей во время работы приложения

...я могу просто догадываться, не видя ваш код, но вы установили у панелей свойство parent? Чтобы отобразить элементы управления на вашей форме, вам НЕОБХОДИМО вставить в обработчик события формы OnCreate следующие две строки:

MyPanel := TPanel.Create(Self);
MyPanel.Parent := Self;

[001490]


Delphi 1

Вызов контекстного меню в позиции курсора II

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

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

procedure TfrmExplorer.TreeViewMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
var P : TPoint;
begin
if Button<>mbRight then exit;
TreeMenu.AutoPopup := False;
if TreeView.GetNodeAt(X,Y)<>NIL then
begin
TreeView.Selected := TreeView.GetNodeAt(X,Y);
P.X := X; P.Y:=Y;
P := TreeView.ClientToScreen(P);
TreeMenu.Popup(P.X,P.Y);
end;
end;

[001503]


Delphi 1

Вызов контекстного меню в позиции курсора III

procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var ClientPoint,ScreenPoint: TPoint;
begin
if Memo1.SelLength>0 then
begin
ClientPoint.X := X;
ClientPoint.Y := Y;
ScreenPoint := ClientToScreen (ClientPoint);
PopupMenu1.Popup (ScreenPoint.X, ScreenPoint.Y);
end;
end;

[001574]


Delphi 2

Иконки в PopupMenu

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;    /**** Элемент для Menu Bar ****/
Open1: TMenuItem;    /**** Элемент для Menu File ****/
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{private declarations}
public
{public declarations}
Icn, Txt, MnuItm: TBitmap;
end;

procedure TForm2.FormCreate(Sender: TObject);
var R: TRect;
HIcn: HIcon;
Ic: TIcon;
Index: Word;
FileName: PChar;
begin
/** Получаем иконку определенного приложения **/
Ic:=TIcon.Create;
Ic.Handle:=ExtractAssociatedIcon(Hinstance, /* задаем путь и имя файла */, Index);
/** Создаем для текста изображение **/
Txt:=TBitmap.Create;
with Txt do
begin
Width:=Canvas.TextWidth(' Тест');
Height:=Canvas.TextHeight(' Тест');
Canvas.TextOut(0,0,' Тест');
end;

/** Копируем иконку в bitmap для изменения его размера. Вы не можете менять размер иконки **/
Icn:=TBitmap.Create;
with Icn do
begin
Width:=32;
Height:=32;
Brush.Color:=clBtnFace;
Canvas.Draw(0,0,Ic);
end;

/** Создаем окончательное изображение, куда мы помещаем иконку и текст **/
MnuItm:=TBitmap.Create;
with MnuItm do
begin
Width:=Txt.Width+18;
Height:=18;
with Canvas do
begin
Brush.Color:=clBtnFace;
Pen.Color:=clBtnFace;
Brush.Style:=bsSolid;
Rectangle(0,0,Width,Height);
CopyMode:=cmSrcAnd;
StretchDraw(Rect(0,0,16,16),Icn);
CopyMode:=cmSrcAnd;
Draw(16,8-(Txt.Height div 2),Txt);
end;
end;
end;

procedure TForm2.FormShow(Sender: TObject);
var
ItemInfo: TMenuItemInfo;
hBmp1   : THandle;
begin
HBmp1:=MnuItm.Handle;
with ItemInfo do
begin
cbSize        := SizeOf( ItemInfo );
fMask         := MIIM_TYPE;
fType         := MFT_BITMAP;
dwTypeData    := PChar(MakeLong( hBmp1, 0 ));
end;

/** Заменяем MenuItem Open1 законченным изображением **/
SetMenuItemInfo( GetSubMenu( MainMenu1.Handle, File1.MenuIndex ),
Open1.MenuIndex, true, ItemInfo );

end;

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

Листинг был изменен для того, чтобы помещать иконки в "чЕкнутое" состояние меню (просто это делает Win95). Это позволяет вам иметь "чЕкнутое" и "нечЕкнутое" состояние.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus,ShellAPI;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Icn, MnuItm : TBitmap;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var R: TRect;
HIcn: HIcon;
Ic: TIcon;
Index: Word;
begin

{     /** Получаем иконку некоторого приложения **/}
Index := 0;    { 11-я иконка в файле }
Ic:=TIcon.Create;
Ic.Handle:=ExtractAssociatedIcon(Hinstance,
'c:\win95\system\shell32.dll', Index);

{     /** Копируем иконку в bitmap для изменения его размера. Вы не можете менять размер иконки **/}
Icn:=TBitmap.Create;

with Icn do
begin
Width:=32;
Height:=32;
Canvas.Brush.Color := clbtnface;
Canvas.Draw(0,0,Ic);
end;

{     /** Создаем окончательное изображение, куда мы помещаем иконку и текст **/}
MnuItm:=TBitmap.Create;
with MnuItm do
begin
Width :=18;
Height:=18;
with Canvas do
begin
Brush.Color:=clbtnface;
Pen.Color:=clbtnface;
CopyMode:=cmSrcAnd;
StretchDraw(Rect(0,0,16,16),Icn);
end;
end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
ItemInfo: TMenuItemInfo;
hBmp1   : THandle;
begin
HBmp1:=MnuItm.Handle;
with ItemInfo do
begin
cbSize        := SizeOf( ItemInfo );
fMask         := MIIM_CHECKMARKS;
fType         := MFT_BITMAP;
hBmpunChecked := HBmp1;     { Неотмеченное (Unchecked) состояние }
hBmpChecked   := HBmp1;     { Отмеченное (Checked) состояние }
end;

{     /** Заменяем MenuItem Open1 законченным изображением **/}
SetMenuItemInfo( GetSubMenu( MainMenu1.Handle, File1.MenuIndex ),
Open1.MenuIndex, true, ItemInfo );

end;

end.

[001538]


Письмо читателя

Вызов контекстного меню в координатах курсора мыши

Тимошенко Александр пишет:

Предлагаю свою процедуру в раздел "Компоненты" - "PopupMenu" - "Вызов контекстного меню в координатах курсора мыши"

procedure TForm1.Form1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X,Y: integer);
var
FCursor   : TPoint;
begin
if Button=mbRight then begin
GetCursorPos(FCursor);
PopupMenu1.Popup(FCursor.X,FCursor.Y);
end;
end;

Процедура, возможно, не особо оригинальна, но все же отличается от двух, ранее представленных в Ваших советах и довольно проста. [001700]


Письмо читателя

ProgressBar с невидимой рамкой

Заказчик моего проекта обратился с просьбой - "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar - нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым. На рисунке сравнение стандартного ProgressBar и ProgressBar с невидимой рамкой.

unit vsprgs;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;

type
TNProgressBar = class(TProgressBar)
procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
private
FShowFrame: boolean;
procedure SetShowFrame(Value: boolean);
protected
public
constructor Create(AOwner: TComponent); override;
published
property ShowFrame: boolean read FShowFrame write SetShowFrame;
end;

procedure Register;

implementation
{ TNProgressBar }
constructor TNProgressBar.Create(AOwner: TComponent);
begin
inherited;
FShowFrame:= True;
end;

procedure TNProgressBar.SetShowFrame(Value: boolean);
begin
if FShowFrame <> Value then begin
FShowFrame:= Value;
RecreateWnd;
end;
end;

procedure TNProgressBar.WMNCPAINT(var Msg: TMessage);
var
DC: HDC;
RC: TRect;
begin
if ShowFrame then begin
inherited;
Invalidate;
end else begin
DC:= GetWindowDC(Handle);
try
Windows.GetClientRect(Handle, RC);
with RC do begin
Inc(Right, 2);
Inc(Bottom, 2);
end;
Windows.FillRect(DC, RC, Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
end;
end;

procedure Register;
begin
RegisterComponents('Controls', [TNProgressBar]);
end;

end.
end.

C уважением, VS [001294]


Можно ли использовать результаты выполнения одного TQuery для другого TQuery?

Nomadic отвечает:

Если Вы работаете с локальными БД, то Вам поможет -

DbiMakePermanent( SourceQuery.Handle, RName, false );

[001343]


Можно ли вызвать хранимую процедуру через TQuery, если она не возвращает курсора?

Nomadic отвечает:

В случае MS SQL нужно написать:

Query1.Sql := 'declare @res' + #13#10 + 'exec MyFunc :Param1, :Param2, @res OUTPUT';
Query1.Open;
Result := Query1.FieldByName( 'Column1' ).Value;
Query1.Close;

[001361]


Delphi 1

TQUERY и TDBGRID

  1. После ключевого слова where используйте оператор order
       Select fname, lname, title
   from T_EMPLOYEE
   where title = 'MGR'
   order by lname, fname
  2. Попробуйте использовать событие ColEnter.
[001374]


Delphi 1

Две и более команд в свойстве TQUERY.SQL

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

Query1.Sql.Clear;
Query1.Close;
Query1.Sql.Add('select * from "monitor.dbf" order by location,dept');
Query1.Open;
Query1.Refresh;

Хитрость кроется в закрытии вашего запроса перед назначением нового. [001376]


Как вставить в нужное место Rich Text в TRichEdit?

Nomadic советует:

Вы можете послать сообщение EM_STREAMIN с параметром SFF_SELECTION методом Perform для замены текущего Selection. Выдержка из Help:

EM_STREAMIN
wParam = (WPARAM) (UINT) uFormat; // Integer
lParam = (LPARAM) (EDITSTREAM FAR *) lpStream; // EDITSTREAM^

The EM_STREAMIN message replaces the contents of a rich edit control with the
specified data stream.

Parameters

uFormat

One of the following data formats, optionally combined with the SFF_SELECTION
flag:

Value Meaning
SF_TEXT Text
SF_RTF Rich-text format
If the SFF_SELECTION flag is specified, the stream replaces the contents of the
current selection. Otherwise, the stream replaces the entire contents of the
control.

lpStream

Pointer to an EDITSTREAM structure. The control reads (streams in) the data by
repeatedly calling the function specified by the structure's pfnCallback
member.

Return Value

Returns the number of characters read.
[001142]


Как указать максимальный размер текста для TRichEdit?

Nomadic советует:

У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться

RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);

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

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.

Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT. [001144]


Delphi 2

Позиция курсора в TRichEdit

Procedure TForm1.GetPosition(Sender: TRichEdit);
var
iX,iY  : Integer;
TheRichEdit : TRichEdit;
begin
iX := 0; iY := 0;
TheRichEdit := TRichEdit(Sender);
iY := SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart,
0);
iX := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX,
iY, 0);
Panel1.Caption := IntToStr(iY + 1) + ':' + IntToStr(iX + 1) ;
end;

procedure TForm1.RichEditMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
GetPosition(RichEdit);
end;

procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
GetPosition(RichEdit);
end;

[001495]


Delphi 2

Прокрутка TRichEdit

Просто используйте сообщение EM_SCROLL:

SendMessage(RichEdit1.Handle, EM_SCROLL, SB_LINEDOWN, 0);

[001586]


Письмо читателя

Об модернизации объекта Richedit

Максим Гуменюк пишет:

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

этот баг я обхожу так.

  1. я создаю потомка Richedit:
    • меню Component\New Component
    • указываю предком TRichedit
  2. Переписаю обработку события WM_INPUTLANGCHANGE, при этом я не вызываю обработчик предка, т.е. Richedit-а
  3. Заодно обрабатываю событие WM_INPUTLANGCHANGEREQUEST, которое сообщает, что пользователь изменил язык. Тут надо вызвать обработчик предка, а то не будет переключаться язык.
Вот что из этого получилось. Имеем исправленный компонент VCL с дополнительным событием.

unit RichEditEx;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;

type
TLangChangeEvent=procedure(Sender:TObject;Lang:HKL) of object;

TRichEditEx = class(TRichEdit)
private
FOnLangChange:TLangChangeEvent;
procedure WMLangRequest(var M:TMessage);message WM_INPUTLANGCHANGEREQUEST;
procedure WMLangChange(var M:TMessage);message WM_INPUTLANGCHANGE;
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
published
property OnLangChange:TLangChangeEvent read FOnLangChange write FOnLangChange;
{ Published declarations }
end;

procedure Register;

implementation

procedure tricheditex.WMLangRequest(var M:TMessage);
begin
if assigned(FOnLangChange) then FOnLangChange(self,m.LParam);
inherited;end;

procedure tricheditex.WMLangChange(var M:TMessage);
begin m.Result:=1;end;

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

end.

Максим Гуменюк, max1gu@fiberia.com [001631]


Письмо читателя

Печать из RichEdit

Nomadic дает для примера такой код:

procedure TForm1.Button1Click(Sender: TObject);
var lst :TextFile;sc :Integer;
begin
//Printer.Orientation:=poPortraite
AssignFile(lst,'prn');
Rewrite(lst);
sc:=0;
for sc:=0 to RichEdit1.Lines.Count-1 do
writeln(lst,StrToOem(RichEdit1.Lines[sc]));
System.CloseFile(lst); end;

[001660]


Группа радиокнопок и ActiveControl

На форме я имею группу радиокнопок. Я хотел бы вызывать контекстно-зависимую подсказку, если пользователь нажал F1. Для данной конкретной группы радиокнопок я установил HelpContext равным 22, но при любом вызове ActiveControl.HelpContext это возвращает (0). Все другие элементы управления работают как положено. Что я делаю неправильно?

Нет. Проблема в том, что ActiveControl - RadioButton, а не RadioButtonGroup. Поместите следующий код в обработчик события формы OnShow, он должен решить вашу проблему:

procedure TForm1.FormShow(Sender: TObject);
var
c: integer;
begin
with RadioGroup1 do begin
for c := 0 to ControlCount - 1 do
TRadioButton(Controls[c]).HelpContext := HelpContext;
end;
end;

- Ralph Friedman [001004]


Мерцание ScrollBar

TScrollBar в Delphi мигает при получении фокуса. Как избежать этого мерцания?

Такая же проблема и при перемещении стандартного бегунка полосы прокрутки. Лечится одинаково: установкой свойства TabStop в False.

- Rick Rogers [001128]


Как отловить сообщения о прокрутке TscrollBar?

Своим опытом делится Олег Кулабухов:

Нижеприведенный пример передвигает второй ScrollBar на такое же количество едениц, на которое передвинет пользователь первый. Т.е. синхронизирует их.

type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}
var
OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin

if TheMessage = WM_VSCROLL then begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_HORZ,
TheRangeMin,
TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_VERT);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle,
SB_HORZ,
TheRange,
true);
end;

if TheMessage = WM_HSCROLL then begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_VERT,
TheRangeMin,
TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_HORZ);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle,
SB_VERT,
TheRange,
true);
end;

{ Call the old Window procedure to }
{ allow processing of the message. }
 NewWindowProc := CallWindowProc(OldWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{ Set the new window procedure for the control }
{ and remember the old window procedure. }
 OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Set the window procedure back }
{ to the old window procedure. }
SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(OldWindowProc));

end;

[001817]


Delphi 1

Drag and Drop из TScrollBox

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

procedure TForm1.GenericMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
TImage(Sender).BeginDrag(False);
{что-то другое, что вы хотели бы сделать}
end;

{....}

UmpteenthDynImage := TImage.Create(dummyImage);
UmpteenthDynImage.MouseDown := TForm1.GenericMouseDown;

Это должно быть синтаксически закрытым. Вы можете просто назначать каждый динамический объект методу GenericMouseDown, и они все им будут пользоваться. Предок dummyImage позволяет легко разрушать все динамические объекты обычным деструктором dummyImage. [001662]


Speedbutton и Glyph

Могу ли я из ресурсов поочередно загружать глифы для кнопок speedbutton и, если да, то как это сделать?

Например, если в вашем проекте используется TDBGrid, то иконки кнопок компонента DBNavigator могут линковаться вашей программой, и их можно загрузить для использования в ваших speedbutton следующим образом:

SpeedButton.Caption := '';
SpeedButton1.Glyph.LoadFromResourcename(HInstance,'DBN_REFRESH');
SpeedButton1.NumGlyphs := 2;

Другие зарезервированные имена:
DBN_PRIOR, DBN_DELETE, DBN_CANCEL, DBN_EDIT, DBN_FIRST, DBN_INSERT, DBN_LAST, DBN_NEXT, DBN_POST

Все имена должны использовать верхний регистр.

- Dennis Passmore [001134]


Delphi 1

Splitter Bar

...я использую TOutline, выровненный с помощью alLeft, и desktop, выровненной по его правой части. Панель расположена после TOutline, и также выровнена с помощью alLeft. Все это дело прилипает к TOutline. Я назвал новую панель 'splitter'. "Отрегулируйте" splitter под себя, сделайте его поУже, создайте красивый контур и нарисуйте двунаправленный курсор. В приведенном ниже примере вы можете заменить TOutLine на нужный вам компонент. Создайте обработчик события мыши и напишите следующий код:

procedure TMainForm.SplitterMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if ssLeft in Shift then begin
outline.Width := outline.Width + X;   {замените OutLine нужным вам объектом}
end;
end;

[001598]


Delphi 1

Показ даты/времени/состояния клавиш в строке состояния

Предположим, у вас есть StatusBar с 4-мя панелями, плюс таймер. Тогда вы можете сделать:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
with StatusBar1 do
begin
if GetKeyState(VK_CAPITAL) <> 0 then
panels[0].text := ' CAP'
else
panels[0].text := '';
if GetKeyState(VK_NUMLOCK) <> 0 then
panels[1].text := ' NUM'
else
panels[1].text := '';
if GetKeyState(VK_SCROLL) <> 0 then
panels[2].text := ' SCRL'
else
panels[2].text := '';
panels[3].text := ' ' +DateTimeToStr(now);
end;
end;

О том, как можно изменить формат вывода даты, доходчиво и с примерами изложено в электронной справке, в разделе, посвященный датам (Date). Обратите внимание на то, что свойство Text имеет тип строки, поэтому вы не можете написать panels[0].text := DateTime(now), т.к. дата/время имеет тип Double.

unit Status;

interface

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

type
TStatus = class(TCustomPanel)
private
FDate         : Boolean;
FKeys         : Boolean;
FTime         : Boolean;
FResources    : Boolean;
DateTimePanel : TPanel;
ResPanel      : TPanel;
ResGauge      : TGauge;
CapPanel      : TPanel;

NumPanel      : TPanel;
InsPanel      : TPanel;
HelpPanel     : TPanel;
UpdateWidth   : Boolean;
FTimer        : TTimer;
procedure SetDate(A: Boolean);
procedure SetKeys(A: Boolean);
procedure SetTime(A: Boolean);
procedure SetResources(A: Boolean);
procedure SetCaption(A: String);
Function  GetCaption: String;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetupPanelFields(ThePanel: TPanel);
procedure SetupPanel(ThePanel: TPanel; WidthMask: String);
procedure UpdateStatusBar(Sender: TObject);
published
property ShowDate: Boolean read FDate write SetDate default True;
property ShowKeys: Boolean read FKeys write SetKeys default True;

property ShowTime: Boolean read FTime write SetTime default True;
property ShowResources: Boolean read FResources write SetResources
default True;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BorderStyle;
property BorderWidth;
property Caption: string read GetCaption write SetCaption;

property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentCtl3d;
property ParentFont;
property ParentShowHint;
property PopUpMenu;
property ShowHint;
property Visible;
end;

procedure Register;
implementation

procedure Register;
begin
RegisterComponents('Additional', [TStatus]);
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin
with ThePanel do
begin
Alignment := taCenter;
Caption := '';
BevelInner := bvLowered;
BevelOuter := bvNone;
{Установите все в True, чтобы все это отразилось на TStatus}
ParentColor := True;
ParentFont := True;

ParentCtl3D := True;
end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: String);
begin
SetupPanelFields(ThePanel);
with ThePanel do
begin
Width := Canvas.TextWidth(WidthMask);
Align := alRight;
end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Parent := TWinControl(AOwner);

FTime := True;
FDate := True;
FKeys := True;
FResources := True;
{Заставляем строку состояния выровняться по нижнему краю}
Align := alBottom;
Height := 19;
BevelInner := bvNone;
BevelOuter := bvRaised;
{Если UpdateWidth равен TRUE, StatusBar пересчитывает только ширину панелей}
UpdateWidth := True;
Locked := True;
TabOrder := 0;;
TabStop := False;
Font.Name := 'Arial';
Font.Size := 8;
{Создаем панель, которая будет отображать дату и время}

DateTimePanel := TPanel.Create(Self);
DateTimePanel.Parent := Self;
SetupPanel(DateTimePanel,'  00/00/00 00:00:00 дп  ');
{СОздаем панель, которая будет содержать графику ресурсов}
ResPanel := TPanel.Create(Self);
ResPanel.Parent := Self;
SetupPanel(ResPanel,'                    ');
{Создаем 2 Gauges, которые размещаем на Resource Panel}
ResGauge := TGauge.Create(Self);
ResGauge.Parent := ResPanel;
ResGauge.Align := alClient;

ResGauge.ParentFont := True;
ResGauge.BackColor := Color;
ResGauge.ForeColor := clLime;
ResGauge.BorderStyle := bsNone;
{Создаем панель, которая будет отображать состояние CapsLock}
CapPanel := TPanel.Create(Self);
CapPanel.Parent := Self;
SetupPanel(CapPanel,'  Cap  ');
{Создаем панель, которая будет отображать состояние NumLock}
NumPanel := TPanel.Create(Self);
NumPanel.Parent := Self;
SetupPanel(NumPanel,'  Num  ');

{Создаем панель, которая будет отображать состояние Insert/Overwrite}
InsPanel := TPanel.Create(Self);
InsPanel.Parent := Self;
SetupPanel(InsPanel,'  Ins  ');
{Создаем панель, которая будет отображать текст состояния}
HelpPanel := TPanel.Create(Self);
HelpPanel.Parent := Self;
SetupPanelFields(HelpPanel);
{Имеем вспомогательную панель, занимающую все остальное пространство}
HelpPanel.Align := alClient;
HelpPanel.Alignment := taLeftJustify;

{Это таймер, который регулярно обновляет строку состояния}
FTimer := TTimer.Create(Self);
If FTimer <> Nil then
begin
FTimer.OnTimer := UpdateStatusBar;
{Обновление происходит дважды в секунду}
FTimer.Interval := 500;
FTimer.Enabled := True;
end;
end;

destructor TStatus.Destroy;
begin
FTimer.Free;
HelpPanel.Free;

InsPanel.Free;
NumPanel.Free;
CapPanel.Free;
ResGauge.Free;
ResPanel.Free;
DateTimePanel.Free;
inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin
FDate := A;
UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin
FKeys := A;
UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin

FTime := A;
UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin
FResources := A;
UpdateWidth := True;
end;

{Если мы получаем или устанавливаем заголовок TStatus, то вместо этого задаем
заголовок HelpPanel}
procedure TStatus.SetCaption(A: String);
begin
HelpPanel.Caption := ' '+A;
end;

function TStatus.GetCaption: String;
begin

GetCaption := HelpPanel.Caption;
end;

{Данная процедура устанавливает соответствующие заголовки}
procedure TStatus.UpdateStatusBar(Sender: TObject);
begin
if ShowDate and ShowTime then
DateTimePanel.Caption := DateTimeToStr(Now)
else
if ShowDate and not ShowTime then
DateTimePanel.Caption := DateToStr(Date)
else
if not ShowDate and ShowTime then

DateTimePanel.Caption := TimeToStr(Time)
else
DateTimePanel.Caption := '';
if UpdateWidth then with DateTimePanel do
if ShowDate or ShowTime then
Width := Canvas.TextWidth(' '+Caption+' ')
else
Width := 0;
if ShowResources then
begin
ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);

if ResGauge.Progress < 20 then
ResGauge.ForeColor := clRed
else
ResGauge.ForeColor := clLime;
end;
if UpdateWidth then
if ShowResources then
ResPanel.Width := Canvas.TextWidth('                    ')
else
ResPanel.Width := 0;
if ShowKeys then
begin
if (GetKeyState(vk_NumLock) and $01) <> 0 then

NumPanel.Caption := '  Num  ' else NumPanel.Caption := '';
if (GetKeyState(vk_Capital) and $01) <> 0 then
CapPanel.Caption := '  Cap  ' else CapPanel.Caption := '';
if (GetKeyState(vk_Insert) and $01) <> 0 then
InsPanel.Caption := '  Ins  ' else InsPanel.Caption := '';
end;
if UpdateWidth then
if ShowKeys then

begin
NumPanel.Width := Canvas.TextWidth(' Num ');
InsPanel.Width := Canvas.TextWidth(' Ins ');
CapPanel.Width := Canvas.TextWidth(' Cap ');
end
else
begin
NumPanel.Width := 0;
InsPanel.Width := 0;
CapPanel.Width := 0;
end;
UpdateWidth := False;
end;

{Позволяем изменять шрифты, используемые панелями для вывода текста}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin
inherited;
UpdateWidth := True;
end;

end.

interface

implementation

end.

[001600]


Письмо читателя

Как вставить в StatusPanel свои компоненты, например ProgressBar? I

Nomadic советует:

pgProgress положить на форму как Visible := false; StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.

>== Режем pаз ==<

procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
if Panel.Index = pnProgress then
begin
pgProgress.BoundsRect := Rect;
pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);
end;
end;

>== Режем два ==< [001624]


Delphi 2

Как вставить в StatusPanel свои компоненты, например ProgressBar? II

unit adStatba;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls;

type
TAdrockStatusBar = class(TStatusBar)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
Constructor Create(Aowner : TComponent); override;
published
{ Published declarations }
end;

procedure Register;

implementation

Constructor TAdrockStatusBar.Create(Aowner : TComponent);
begin
inherited Create(Aowner);
ControlStyle               := ControlStyle + [csAcceptsControls];
end;

procedure Register;
begin
RegisterComponents('Adrock', [TAdrockStatusBar]);
end;

end.

Это позволит вам разместить элемент управления в панели. Но этот способ не поддерживает использование вложенных панелей. Вероятно, вам также понадобиться выровнять элемент управления по правому краю. Не так это все сложно... [001625]


Обновление картинки в ячейке StringGrid

SottNick советует:

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

StringGrid1.Cells[i,j]:='';

или

StringGrid1.Cells[i,j]:=StringGrid1.Cells[i,j];

если там что-то хранится [001045]


Многострочность в заголовках колонок StringGrid

У меня есть StringGrid, который выглядит очень красивым, за исключением заголовков колонок, где я хотел бы иметь их размер равным 1 ячейке, но с заголовком, размещенным в нескольких строках, например,
Индекс Фондовой Биржи
показывалось бы как

   Индекс
   Фондовой
   Биржи
было бы классно, если можно было этот заголовок размещать еще и по центру.

Рисовать сами ячейки вы можете в обработчике события OnDrawCell. Для определения ячейки (заголовок?), обрабатываемой в текущий момент, используйте параметр GridState.

Я выводил тест с помощью обычных методов рисования (которые хорошо "приживаются" в данном компоненте), с поддержкой вертикального выравнивания, полей и переноса слов. Вот сам код:

TFTVerticalAlignment = (vaTop, vaMiddle, vaBottom);

procedure DrawTextAligned(const Text: string; Canvas: TCanvas; var Rect: TRect; Alignment: TAlignment; VerticalAlignment: TFTVerticalAlignment; WordWrap: Boolean);
var
P : array[0..255] of Char;
H : Integer;
T : TRect;
F : Word;
begin
StrPCopy(P, Text);
T := Rect;
with Canvas, Rect do
begin
F := DT_CALCRECT or DT_EXPANDTABS or DT_VCENTER or TextAlignments[Alignment];
if WordWrap then F := F or DT_WORDBREAK;
H := DrawText(Handle, P, -1, T, F);
H := MinInt(H,Rect.Bottom - Rect.Top);
if VerticalAlignment = vaMiddle then
begin
Top := ( (Bottom+Top) - H) div 2;
Bottom := Top + H;
end
else if VerticalAlignment = vaBottom then
Top := Bottom - H - 1;
F := DT_EXPANDTABS or DT_VCENTER or TextAlignments[Alignment];
if WordWrap then F := F or DT_WORDBREAK;
DrawText(Handle, P, -1, Rect, F);
end;
end;

- Rick Rogers [001050]


StringGrid без выделенной ячейки

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

Вам необходимо создать обработчик события OnDrawCell. Это легче чем вы думаете. Вот образец кода, который сделает вас счастливым:

procedure TForm.sgrDrawCells(Sender: TObject; Col, Row: Longint; Rect: TRect;
State: TGridDrawState);
var
ACol: longint absolute Col;
ARow: longint absolute Row;
Buf: array[byte] of char;
begin
if State = gdFixed then
Exit;

with sgrGrid do begin
Canvas.Font := Font;
Canvas.Font.Color := clWindowText;
Canvas.Brush.Color := clWindow;

Canvas.FillRect(Rect);
StrPCopy(Buf, Cells[ACol,ARow]);
DrawText(Canvas.Handle, Buf, -1, Rect,
DT_SINGLELINE or DT_VCENTER or DT_NOCLIP or DT_LEFT);
end;
end;

- Jeff Fisher [001107]


Один щелчок на StringGrid вместо трех

Как сделать так, чтобы после ПЕРВОГО щелчка на ячейке возможно было бы начать редактировать ее содержимое?

Включите goAlwaysShowEditor в свойство TStringGrid Options.

- Rick Rogers [001109]


Delphi 1

StringGrid как DBGrid

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

table.first;
row := 0;
grid.rowcount := table.recordCount;
while not table.eof do begin
for i := 0 to table.fieldCount-1 do
grid.cells[i,row] := table.fields[i].asString;
inc (row);
table.next;
end;

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

PROCEDURE        TformLookupDB.FillCells;
VAR     Row, i     :INTEGER
w         :INTEGER
grid      :TStringGrid

BEGIN
doGrid.RowCount := 0;
IF NOT ASSIGNED(fDB) THEN EXIT;
Row := 0;
FOR i := LOW(fColWidths) TO HIGH(fColWidths) DO fColWidths[i] := 100
// Данный временный объект-сетка используется для предохранения от огромного
// количества подразумеваемых событий Application.ProcessMessages,
// инициируемых базой данных, и вызывающих противное моргание объекта
// doGrid. Итак, мы загружаем данные в объект-сетку
// и затем копируем их в стобцы, начиная с верхней части.
grid := TStringGrid.Create(Self);
grid.Visible := FALSE;
WITH fDB
DO        TRY
grid.ColCount := fFields.Count;
DisableControls;
// Фильтр был установлен с помощью свойства Self.Filter
First;
WHILE NOT EOF
DO        TRY
grid.RowCount := Row+1;
FOR i := 0 TO grid.ColCount-1
DO        BEGIN
grid.Cells[i,Row] :=
FieldByName( fFields.Strings[i] ).AsString
w := doGrid.Canvas.TEXTWIDTH( grid.Cells[i,
Row] );
IF fColWidths[i]<w THEN fColWidths[i] := w;
END
INC(Row);
FINALLY
Next;
END
FINALLY
doGrid.RowCount := grid.RowCount;
doGrid.ColCount := grid.ColCount;
FOR i := 0 TO grid.ColCount-1
DO        BEGIN
doGrid.Cols[i] := grid.Cols[i];
doGrid.ColWidths[i] := fColWidths[i] + 4
END
grid.Free;
EnableControls
END
END;

[001366]


`Авторазмер` для StringGrid

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

i,j,temp,max: integer;

for i := 0 to grid.colcount-1 do begin
max := 0;
for j := 0 to grid.rowcount-1 do begin
temp := grid.canvas.textWidth (grid.cells[i,j]);
if temp > max then max := temp;
end;
grid.colWidths[i] := max + grid.gridLineWidth +1;
end;

Вероятно, вам необходимо будет добавить +1, чтобы текст не прилипал к границам ячеек. [001444]


Выравнивание колонок StringGrid III

Вот некоторый код, который делает то, что вы хотите:

procedure WriteText(ACanvas: TCanvas; const ARect: TRect; DX, DY: Integer;
const Text: string; Format: Word);
var
S: array[0..255] of Char;
B, R: TRect;

begin
with ACanvas, ARect do
begin
case Format of
DT_LEFT   : ExtTextOut(Handle, Left + DX, Top + DY, ETO_OPAQUE or ETO_CLIPPED,
@ARect, StrPCopy(S, Text), Length(Text), nil);

DT_RIGHT  : ExtTextOut(Handle, Right - TextWidth(Text) - 3, Top + DY,
ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text),
Length(Text), nil);

DT_CENTER : ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div 2,
Top + DY, ETO_OPAQUE or ETO_CLIPPED, @ARect,
StrPCopy(S, Text), Length(Text), nil);
end;
end;
end;

procedure TBEFStringGrid.DrawCell(Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var

procedure Display(const S: string; Alignment: TAlignment);
const
Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
begin
WriteText(Canvas, Rect, 2, 2, S, Formats[Alignment]);
end;

begin
{ здесь задаем аргументы Col и Row, и форматируем как угодно ячейки }

case Row of
0     : { Центрирование заголовков колонок }
if (Col < ColCount) then
Display(Cells[Col,Row], taCenter)
else
{ Все другие данные имеют правое центрирование }
Display(Cells[Col,Row], taRight);
end;

end;

[001457]


Delphi 1

Выравнивание колонок StringGrid IV

Создайте ваш собственный метод drawcell на примере того, что приведен ниже:

procedure Tsearchfrm.Grid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
var l_oldalign : word;

begin
if (row=0) or (col<2) then
grid1.canvas.font.style:=grid1.canvas.font.style+[fsbold]; {устанавливаем заголовок в жирном начертании}

if col<>1 then
begin
l_oldalign:=settextalign(grid1.canvas.handle,ta_right);
{NB использует для рисования правую сторону квадрата}
grid1.canvas.textrect(rect,rect.right-2, Rect.top+2,grid1.cells[col,row]);
settextalign(grid1.canvas.handle,l_oldalign);
end
else
begin
grid1.canvas.textrect(rect,rect.left+2,rect.top+2,grid1.cells[col,row]);
end;

grid1.canvas.font.style:=grid1.canvas.font.style-[fsbold];

end;

[001466]


Письмо читателя

Выравнивание колонок StringGrid V

Pavel Stont предлагает свой вариант TStringGrid'а с выравниванием строк:

{
Код компонента для Delphi на основе стандартного TStringGrid.

Компонет позволяет переносить текст в TStringGrid.

В качестве исходного текста был использован компонент TWrapGrid.
Автор Luis J. de la Rosa.
E-mail: delarosa@ix.netcom.com
Вы свободны в использовании, распространении и улучшении кода.
Пожалуйста шлите любые комментарии и пожелания на адрес delarosa@ix.netcom.com.

Далее были внесены изменения в исходный код, а именно добавлены методы вывода
текста:
1. atLeft - Вывод текста по левой границе;
2. atCenter - Вывод текста по центру ячейки (по горизонтали);
3. atRight - Вывод текста по правой границе;
4. atWrapTop - Вывод и перенос текста по словам относительно верхней границы
ячейки;
5. atWrapCenter - Вывод и перенос текста по словам относительно центра ячейки
(по вертикали);
6. atWrapBottom - Вывод и перенос текста по словам относительно нижней границы
ячейки;

Вносил изменения и тестировал в Delphi 3/4/5:
Автор Pavel Stont.
E-mail: pavel_stont@mail.ru.
Никаких ограничений на использование, распростанение и улучшение кода не налогаются.
Буду очень признателен, если о всех замеченных неполадках сообщите по e-mail.

Для использования:
Выберите в Delphi пункты меню 'Options' - 'Install Components'.
Нажмите 'Add'.
Найдите и выберите файл с именем 'NewStringGrid.pas'.
Нажмите 'OK'.
После этого вы увидете компонент во вкладке "Other" палитры компонентов
Delphi.
После этого вы можете использовать компонент вместо стандартного TStringGrid.

Успехов!

Несколько дополнительных замечаний по коду:
1. Методы Create и DrawCell были перекрыты.
2. Введены два новых свойства, а именно AlignText и AlignCaption соответсвенно методы
выравнивания текста в ячейках данных (обычно - белого цвета) и в фиксированных ячейках
(обычно - серого цвета).
3. Свойство Center - центрация текста по горизонтали независимо от метода.
}
unit NewStringGrid;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids;

type
TAlignText=(atLeft,atCenter,atRight,atWrapTop,atWrapCenter,atWrapBottom);

type
TNewStringGrid = class(TStringGrid)
private
{ Private declarations }
FAlignText: TAlignText;
FAlignCaption: TAlignText;
FCenter: Boolean;
procedure SetAlignText(Value: TAlignText);
procedure SetAlignCaption(Value: TAlignText);
procedure SetCenter(Value: Boolean);
protected
{ Protected declarations }
procedure DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState); override;
public
{ Public declarations }
constructor Create(AOwner : TComponent); override;
published
{ Published declarations }
property AlignText: TAlignText read FAlignText write SetAlignText;
property AlignCaption: TAlignText read FAlignCaption write SetAlignCaption;
property Center: Boolean read FCenter write SetCenter;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Other', [TNewStringGrid]);
end;

{ TNewStringGrid }

constructor TNewStringGrid.Create(AOwner: TComponent);
begin
{ Создаем TStringGrid }
inherited Create(AOwner);
{ Задаем начальные параметры компонента }
AlignText:=atLeft;
AlignCaption:=atCenter;
Center:=False;
DefaultColWidth:=80;
DefaultRowHeight:=18;
Height:=100;
Width:=408;
{ Заставляем компонент перерисовываться нашей процедурой
по умолчанию DrawCell }
DefaultDrawing:=FALSE;
end;

{ Процедура DrawCell осуществляет перенос текста в ячейке }
procedure TNewStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState);
var
CountI,                    { Счетчик }
CountWord: Integer;        { Счетчик }
Sentence,                  { Выводимый текст }
CurWord: String;           { Текущее выводимое слово }
SpacePos,                  { Позиция первого пробела }
CurXDef,                   { X-координата 'курсора' по умолчанию }
CurYDef,                   { Y-координата 'курсора' по умолчанию }
CurX,                      { Х-координата 'курсора' }
CurY: Integer;             { Y-координата 'курсора' }
EndOfSentence: Boolean;    { Величина, указывающая на заполненность ячейки }
Alig: TAlignText;          { Тип выравнивания текста }
ColPen: TColor;            { Цвет карандаша по умолчанию }
MassWord: Array [0..255] Of String;
MassCurX,MassCurY: Array [0..255] Of Integer;
LengthText: Integer;       { Длина текущей строки }
MassCurYDef: Integer;
MeanCurY: Integer;

procedure VisualCanvas;
begin
{ Прорисовываем ячейку и придаем ей 3D-вид }
With Canvas Do Begin
{ Запоминаем цвет пера для последующего вывода текста }
ColPen:=Pen.Color;
If gdFixed in AState Then Begin
Pen.Color:=clWhite;
MoveTo(ARect.Left,ARect.Top);
LineTo(ARect.Left,ARect.Bottom);
MoveTo(ARect.Left,ARect.Top);
LineTo(ARect.Right,ARect.Top);
Pen.Color:=clBlack;
MoveTo(ARect.Left,ARect.Bottom);
LineTo(ARect.Right,ARect.Bottom);
MoveTo(ARect.Right,ARect.Top);
LineTo(ARect.Right,ARect.Bottom);
End;
{ Восстанавливаем цвет пера }
Pen.Color:=ColPen;
End;
end;

procedure VisualBox;
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;
end;

procedure VisualText(Alig: TAlignText);
begin
Case Alig Of
atLeft:       Begin
With Canvas Do
{ выводим текст }
TextOut(CurX,CurY,Sentence);
VisualCanvas;
End;
atRight:      Begin
With Canvas Do
{ выводим текст }
TextOut(ARect.Right-TextWidth(Sentence)-2,CurY,Sentence);
VisualCanvas;
End;
atCenter:     Begin
With Canvas Do
{ выводим текст }
TextOut(ARect.Left+((ARect.Right-ARect.Left-TextWidth(Sentence)) div 2),CurY,Sentence);
VisualCanvas;
End;
atWrapTop:    Begin
{ для каждого слова ячейки }
EndOfSentence:=FALSE;
CountI:=0;
While CountI<=SpacePos Do Begin
MassWord[CountI]:='';
CountI:=CountI+1;
End;
CountI:=0;
CountWord:=CurY;
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
{ если текст выходит за границы ячейки }
LengthText:=TextWidth(CurWord)+CurX+2;
If LengthText>ARect.Right Then Begin
{ переносим на следующую строку }
CurY:=CurY+TextHeight(CurWord);
CurX:=CurXDef+2;
End;
If CountWord<>CurY Then CountI:=CountI+1;
MassWord[CountI]:=MassWord[CountI]+CurWord;
{ увеличиваем X-координату курсора }
CurX:=CurX+TextWidth(CurWord);
CountWord:=CurY;
End;
End;
With Canvas Do Begin
CountWord:=0;
CurY:=CurYDef+2;
CurX:=CurXDef+2;
While CountWord<=CountI Do Begin
Case Center Of
True:  Begin
CurWord:=MassWord[CountWord];
If Copy(CurWord,Length(CurWord)-1,1)=' ' Then
MassWord[CountWord]:=Copy(CurWord,0,Length(CurWord)-1);
MassCurX[CountWord]:=ARect.Left+((ARect.Right-ARect.Left-TextWidth(MassWord[CountWord])) div 2);
MassWord[CountWord]:=CurWord;
End;
False: MassCurX[CountWord]:=CurX;
End;
MassCurY[CountWord]:=CurY;
{ выводим слово }
TextOut(MassCurX[CountWord],MassCurY[CountWord],MassWord[CountWord]);
CurY:=CurY+TextHeight(MassWord[CountWord]);
CountWord:=CountWord+1;
End;
End;
VisualCanvas;
End;
atWrapCenter: Begin
{ для каждого слова ячейки }
EndOfSentence:=FALSE;
CountI:=0;
While CountI<=SpacePos Do Begin
MassWord[CountI]:='';
CountI:=CountI+1;
End;
CountI:=0;
CountWord:=CurY;
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
{ если текст выходит за границы ячейки }
LengthText:=TextWidth(CurWord)+CurX+2;
If LengthText>ARect.Right Then Begin
{ переносим на следующую строку }
CurY:=CurY+TextHeight(CurWord);
CurX:=CurXDef+2;
End;
If CountWord<>CurY Then CountI:=CountI+1;
MassWord[CountI]:=MassWord[CountI]+CurWord;
{ увеличиваем X-координату курсора }
CurX:=CurX+TextWidth(CurWord);
CountWord:=CurY;
End;
End;
With Canvas Do Begin
CountWord:=0;
CurX:=CurXDef+2;
While CountWord<=CountI Do Begin
Case Center Of
True:  Begin
CurWord:=MassWord[CountWord];
If Copy(CurWord,Length(CurWord)-1,1)=' ' Then
MassWord[CountWord]:=Copy(CurWord,0,Length(CurWord)-1);
MassCurX[CountWord]:=ARect.Left+((ARect.Right-ARect.Left-TextWidth(MassWord[CountWord])) div 2);
MassWord[CountWord]:=CurWord;
End;
False: MassCurX[CountWord]:=CurX;
End;
MassCurY[CountWord]:=TextHeight(MassWord[CountWord]);
CountWord:=CountWord+1;
End;
CountWord:=0;
MassCurYDef:=0;
While CountWord<=CountI Do Begin
MassCurYDef:=MassCurYDef+MassCurY[CountWord];
CountWord:=CountWord+1;
End;
MassCurYDef:=(ARect.Bottom-ARect.Top-MassCurYDef) div 2;
CountWord:=0;
MeanCurY:=0;
While CountWord<=CountI Do Begin
MassCurY[CountWord]:=ARect.Top+MeanCurY+MassCurYDef;
MeanCurY:=MeanCurY+TextHeight(MassWord[CountWord]);
CountWord:=CountWord+1;
End;
CountWord:=-1;
While CountWord<=CountI Do Begin
CountWord:=CountWord+1;
If MassCurY[CountWord]<(ARect.Top+2) Then Continue;
{ выводим слово }
TextOut(MassCurX[CountWord],MassCurY[CountWord],MassWord[CountWord]);
End;
End;
VisualCanvas;
End;
atWrapBottom: Begin
{ для каждого слова ячейки }
EndOfSentence:=FALSE;
CountI:=0;
While CountI<=SpacePos Do Begin
MassWord[CountI]:='';
CountI:=CountI+1;
End;
CountI:=0;
CountWord:=CurY;
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
{ если текст выходит за границы ячейки }
LengthText:=TextWidth(CurWord)+CurX+2;
If LengthText>ARect.Right Then Begin
{ переносим на следующую строку }
CurY:=CurY+TextHeight(CurWord);
CurX:=CurXDef+2;
End;
If CountWord<>CurY Then CountI:=CountI+1;
MassWord[CountI]:=MassWord[CountI]+CurWord;
{ увеличиваем X-координату курсора }
CurX:=CurX+TextWidth(CurWord);
CountWord:=CurY;
End;
End;
With Canvas Do Begin
CountWord:=0;
CurX:=CurXDef+2;
While CountWord<=CountI Do Begin
Case Center Of
True:  Begin
CurWord:=MassWord[CountWord];
If Copy(CurWord,Length(CurWord)-1,1)=' ' Then
MassWord[CountWord]:=Copy(CurWord,0,Length(CurWord)-1);
MassCurX[CountWord]:=ARect.Left+((ARect.Right-ARect.Left-TextWidth(MassWord[CountWord])) div 2);
MassWord[CountWord]:=CurWord;
End;
False: MassCurX[CountWord]:=CurX;
End;
MassCurY[CountWord]:=TextHeight(MassWord[CountWord]);
CountWord:=CountWord+1;
End;
CountWord:=0;
MassCurYDef:=0;
While CountWord<=CountI Do Begin
MassCurYDef:=MassCurYDef+MassCurY[CountWord];
CountWord:=CountWord+1;
End;
MassCurYDef:=ARect.Bottom-MassCurYDef-2;
CountWord:=0;
MeanCurY:=-MassCurY[CountWord];
While CountWord<=CountI Do Begin
MeanCurY:=MeanCurY+MassCurY[CountWord];
MassCurY[CountWord]:=MassCurYDef+MeanCurY;
CountWord:=CountWord+1;
End;
CountWord:=-1;
While CountWord<=CountI Do Begin
CountWord:=CountWord+1;
If MassCurY[CountWord]<(ARect.Top+2) Then Continue;
{ выводим слово }
TextOut(MassCurX[CountWord],MassCurY[CountWord],MassWord[CountWord]);
End;
End;
VisualCanvas;
End;
End;
end;

begin
VisualBox;
VisualCanvas;
{ Начинаем рисование с верхнего левого угла ячейки }
CurXDef:=ARect.Left;
CurYDef:=ARect.Top;
CurX:=CurXDef+2;
CurY:=CurYDef+2;
{ Здесь мы получаем содержание ячейки }
Sentence:=Cells[ACol,ARow];
{ Если ячейка пуста выходим из процедуры }
If Sentence='' Then Exit;
{ Проверяем длину строки (не более 256 символов) }
If Length(Sentence)>256 Then Begin
MessageBox(0,'Число символов не должно быть более 256.','Ошибка в таблице',mb_OK);
Cells[ACol,ARow]:='';
Exit;
End;
{ Узнаем сколько в предложении слов и задаем размерность массивов }
SpacePos:=Pos(' ',Sentence);
{ Узнаем тип выравнивания текста }
If gdFixed in AState Then Alig:=AlignCaption
Else Alig:=AlignText;
VisualText(Alig);
end;

procedure TNewStringGrid.SetAlignCaption(Value: TAlignText);
begin
If Value<>FAlignCaption Then
FAlignCaption:=Value;
end;

procedure TNewStringGrid.SetAlignText(Value: TAlignText);
begin
If Value<>FAlignText Then
FAlignText:=Value;
end;

procedure TNewStringGrid.SetCenter(Value: Boolean);
begin
If Value<>FCenter Then
FCenter:=Value;
end;

end.

[001796]


Delphi 1

Покрашенный StringGrid I

...вы можете попробовать использовать StringGrid. У него имеется свойство Objects, через которое вы можете назначать объекты. Создайте объект, содержащий переменную типа TColor, и назначьте это Objects[col,row], что позволит иметь к нему доступ в любое время. Назначьте событие OnDrawCell StringGrid, позволяющее рисовать текст ячейки правильного цвета. Чтобы убедиться, что ячейка выбрана, воспользуйтесь свойством Selection, содержащим то, что выбрал пользователь. Все это должно выглядеть приблизительно так:

type
TStrColor = class(TObject)
public
Color : TColor;  {вы могли бы также определить частные и
публичные методы доступа}
end;
...
procedure TForm1.FormCreate(Sender:TObject)
var
i,j : Integer;
begin
With StringList1 do
for i := 0 to ColCount-1
for j := 0 to RowCount-1
Objects[i,j] := TStrColor.Create;
end;
...
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
var
OldColor : TColor;
begin
with StringGrid1.Canvas do begin
OldColor := Font.Color;
Font.Color := (StringGrid1.Objects[col,row] as TStrColor).Color;
TextOut(Rect.Left+2,Rect.Top+2,StringGrid1.Cells[Col,Row]);
Font.Color := OldColor;
end;
end;
...
procedure TForm1.ProcessSelection(Sender: TObject);
var
i,j : Integer;
begin
With StringGrid1.Selection do
For i := left to right do
for j := top to bottom do
MessageDlg(IntToStr(i)+','+IntToStr(j)+'-'+
IntToStr((StringGrid1.Objects[i,j] as TStrColor).Color),
mtInformation,[mbOk],0);
end;

Этот компонент не позволяет делать многочисленный выбор.... [001479]


Delphi 1

Покрашенный StringGrid II

В данном модуле демонстрируется техника изменения цвета у выводимого в StringGrid текста.

unit Strgr;

interface

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

type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
const
CharOffset = 3;
begin
with StringGrid1.canvas do
begin
font.color := clMaroon;
textout(rect.left + CharOffset, rect.top + CharOffset, 'L');
font.color := clNavy;
textout(rect.left + CharOffset + TextWidth('L'),
rect.top + CharOffset, 'loyd');
end;
end;
end.

[001499]


Delphi 1

Редактирование в StringGrid

...правда, я этого не пробовал, но в голову пришли две идеи:

  1. Нажмите на втором поле редактировании, переведите фокус на другое поле (например, x.focus, где x не сетка), сбросьте goEditing и selectRow и затем верните фокус назад сетке. (Эта техника работала у меня в нескольких местах, например, в градах и мемах.)

  2. Нажмите на втором поле редактирования, и после сброса goEditing и selectRow, попробуйте создать tGridRect, подсвечивающий нужную вам строку, после чего делайте grid.Selection := gridRect;
[001511]


Сбрасывается HighLight-цвет выбранной ячейки в StringGrid

Очевидно, вы установили DefaultDrawing в False. Это плохой выбор, поскольку в этом случае вы лишаетесь всех правильно и заранее нарисованных для вас элементов TGrids. Когда я сам создавал свой TWrapGrid, я вначале тоже выключил эту фичу и пытался подобрать нужный цвет сам, но я окончательно запутался, и думаю, что лучше, чем это сделает DefaultDrawing-обработчик, вам не сделать, а вы потом сделаете все остальное. Но если вы настаиваете на собственном подборе цвета и рисовании ячеек во всех их ипостасях (выбранные, с фокусом, выбранные с фокусом, и пр.), вы просто должны ознакомиться с исходным кодом Grid и посмотреть как это реализовать ПРАВИЛЬНО. [001550]


Delphi 1

Tab как Enter в StringGrid

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

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
begin

if Key = #13 then
with StringGrid1 do
if Col < ColCount-1 then {следующая колонка!}
Col := Col + 1
else if Row < RowCount-1 then begin {следующая строка!}
Row := Row + 1;
Col := 1;
end else begin {Конец сетки! - Снова перемещаемся наверх!}
Row := 1;
Col := 1;
{или вы можете передать управление другому элементу управления}
end;
end;

[001553]


Delphi 1

Поиск по маске в StringGrid

list : tStringList;   { tStringList для поиска }
target: string;       { строка для поиска, например. 'LeftPelvic' }

{ устанавливаем позицию для начала поиска, например, 0 для старта с самого начала,
или другое целое для старта с любого места списка, например i + 1 для последнего значения }
{ приведенный ниже код делает поиск нечувствительным к регистру,
если вам нужно обратное, уберите вызов ansiUpperCase }
target := ansiUpperCase (target);
for i := start to list.count-1 do
if ansiUpperCase(copy(list.item[i], 1, length(target))) = target then
мы нашли это!

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

if pos (target, ansiUpperCase(list.item[i])) > 0 then мы нашли это;

[001557]


Delphi 1

Потеря визуального курсора в StringGrid

У меня была та же проблема, и потратил немало смекалки чтобы решить ее. Если DefaultRowHeight <= 14, визуальный курсор исчезает! Мое решение заключается в установке DefaultRowHeight в 15. [001558]


Delphi 1

Многострочный TStringGrid

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

if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
procedure TForm1.grid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);

var l_oldalign : word;
l_YPos,l_XPos,i : integer;
s,s1 : string;
l_col,l_row :longint;

begin
l_col := col;
l_row := row;
with sender as tstringgrid do
begin
if (l_row=0) then
canvas.font.style:=canvas.font.style+[fsbold];
if l_row=0 then
begin
l_oldalign:=settextalign(canvas.handle,ta_center);
l_XPos:=rect.left + (rect.right - rect.left) div 2;
s:=cells[l_col,l_row];
while s<>'' do
begin
if pos(#13,s)<>0 then
begin
if pos(#13,s)=1 then
s1:=''
else
begin
s1:=trim(copy(s,1,pred(pos(#13,s))));
delete(s,1,pred(pos(#13,s)));
end;
delete(s,1,2);
end
else
begin
s1:=trim(s);
s:='';
end;
l_YPos:=rect.top+2;
canvas.textrect(rect,l_Xpos,l_YPos,s1);
inc(rect.top,rowheights[l_row] div 3);
end;
settextalign(canvas.handle,l_oldalign);
end
else
begin
canvas.textrect(rect,rect.left+2,rect.top+2,cells[l_col,l_row]);
end;

canvas.font.style:=canvas.font.style-[fsbold];
end;
end;

[001560]


Delphi 1

Множественный выбор в TStringGrid

То же самое я проделывал и с DBGrid. (Пока не реализован Shift-MouseDown, только Ctrl-MouseDown).

Для TStringGrid вам нужно выполнить следующие шаги:

  1. Заполните сетку, связывая Objects[0, ARow] с некоторым логическим объектом типа:

    TBooleanObject = class(TObject)
    public
    Flag    : Boolean ;
    end ;

  2. В обработчике события OnMouseDown и OnKeyDown измените флаг, как того требует ситуация.
  3. В обработчике события OnDrawCell отрисуйте строку согласно флагу Objects[0,ARow].
[001564]


Delphi 1

Событие OnDraw для TStringGrid

Это код, который я использую для печати TMemoField в TDBGrid. Перекрываем (override) метод DrawCell:

Canvas.FillRect(ARect);
R := ARect;
WITH TMemoField(Field) DO
DrawText(Canvas.Handle, PChar(Value), Length(Value), R,
DT_WORDBREAK OR DT_NOPREFIX);

Я думаю этот код, который я создал в Delphi 1.0, должен помочь вам:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
var  bufB : array[0..79] of Char;  algn : Word;
begin
algn := 0;
if  (Col = NumbColK) or (Col = PrceColK) or
(Col = TtlColK)   then  algn := dt_Right;
if  Row = 0  then  algn := dt_Center;
if  algn = 0  then  Exit;
StringGrid1.Canvas.FillRect(Rect);

StrPCopy(bufB, StringGrid1.CellS[Col, Row]);
Rect.Top := Rect.Top+2;  Rect.Right := Rect.Right-2;
DrawText(StringGrid1.Canvas.Handle, bufB, -1, Rect, algn);
end;

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

grid.cells[col,row] :=
trimWithDots (myString, form1.canvas, grid.widths[col]-2);

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

function trimWithDots (const myString: string; canvas: tCanvas; wid: integer):
string;
begin
result := myString;
while canvas.textWidth (result) > wid do
delete (result, length(result), 1);
end;

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

Если вы не загружаете сетку из другого источника, вы можете все делать так, как описано выше, но помещая код в обработчик события onDrawDataCell. В этом случае сетка нарисует за вас все линии, вам же останется нарисовать только содержимое. [001572]


Delphi 1

Ограничение длины поля TStringGrid

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

if key <> #8 then begin {допускаем backspace/Del}
len := length(grid.cells[grid.col, grid.row]);
if len >= ваша желаемая максимальная длина then begin
messageBeep (0);
key := #0;
end;
end;

После получения вышеуказанным кодом строки s проверяется условие и,

if Length(s) > maxlengthoffield then exit;

[001577]


Delphi 1

Правое выравнивание текста в TEdit и колонок в TStringGrid

8.  Очевидно, это может быть сделано одним из двух способов:

8.1   Редактируя строчные неформатированные числа с левым
      выравниванием, а после покидания фокуса у
      компонента, о котором идет речь, происходит
      форматирование и выравнивание по правому краю.
      Это потребует от нас переключения на
      ES_MULTILINE/ES_RIGHT в момент потери фокуса.

8.2   Постоянное переформатирование при вводе
      пользователем каждой цифры. Мой опыт подсказывает,
      что Edit Control должен иметь функцию обратного вызова
      для переформатирования в "real-time" и отображении
      частично отредактированных результатов. Я пришел из
      мира Macintosh, поэтому мне самому нужна помощь по
      созданию функции обратного вызова (callback function)
      для элементов управления Microsoft, я предложил
      всего-лишь идею.
...вероятно я сплоховал, и не существует простого пути для правого выравнивания текста в поле редактирования (Windows Edit Control), кроме как задания его стиля ES_MULTILINE, а также ES_RIGHT. (Полное переписывание MS Edit Control есть задача далеко нетривиальная).
[001582]


Delphi 1

Размер экрана и TStringGrid

...я сталкивался с той же, описанной вами проблемой. Я наблюдал это, когда Delphi масштабировала свойство Font у StringGrid, не изменяя при этом свойства StringGrid "DefaultColWidth" и "DefaultRowHeight". Таким образом, сам StringGrid размера не менял.

Я обошел это, изменяя сами эти свойства:

with StringGrid1 do begin
DefaultColWidth  := DefaultColWidth  * MyScaleFactor;
DefaultRowHeight := DefaultRowHeight * MyScaleFactor;
end;

[001584]


Delphi 1

SetFocus в TStringGrid

Grid.Row := YourRowNumber;
Grid.TopRow := YourFirstVisibleRow;
Grid.LeftCol := YourFirstVisibleColumn;

[001592]


Delphi 1

Форматирование ячеек TStringGrid

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

Вам нужно сделать пару вещей:

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

begin
if (Row > 0) and (Col > 0) and (grdDivBudget.Cells[Col, Row] <> '') then
begin
{Формат строки с числом с плавающей точкой}
strText := FloatToStrF(StrToFloat(grdDivBudget.Cells[Col, Row]),
ffNumber,         13,2);

{Устанавливаем шрифт}
grdDivBudget.Canvas.Font.Name := 'Courier';
if StrToFloat(grdDivBudget.Cells[Col, Row]) < 0 then
grdDivBudget.Canvas.Font.Color := clRed;
grdDivBudget.Canvas.Font.Style := grdDivBudget.Canvas.Font.Style -
[fsBold];

{Центрируем текст в ячейке по вертикали, по правому полю,
и отодвигаем его от правого поля на два пикселя.}
X := Rect.Right - grdDivBudget.Canvas.TextWidth(strText);
Y := Rect.Top + ((Rect.Bottom - Rect.Top -
grdDivBudget.Canvas.TextHeight(strText)) div 2);
Dec(Rect.Right, 2);

grdDivBudget.Canvas.TextRect(Rect, X, Y, strText);
end;

Убедитесь в том, что вы имеете DefaultDrawing := True, так, чтобы вы могли в ячейках выводить только текст, остальную отрисовку за вас сделает VCL.

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

Но при этом вы можете обнаружить, что проверка данных для данного способа может быть проблематична (например, что будет, если пользователь введет 'TX' в числовой колонке). Эта ситуация усугубляется тем фактом, что сетка (во всяком случае DrawGrid) не позволяет реализовать "последовательное поведение" для различных путей навигации по сетке (например, инициализировать различные события, если вы пользуетесь курсорными стрелками, мышью, или просто нажимаете Enter). Но и это все решается простой посылкой другого сообщения (позже я расскажу вам как это можно сделать). [001604]


Delphi 1

Правое выравнивание ячеек TStringGrid

Я полагаю, это лучший метод:

procedure TForm1.GridSumaDrawCell(Sender: TObject; ACol, ARow: Longint;
ARect: TRect; State: TGridDrawState);
var
dx : integer;
begin
with (Sender as TStringGrid).Canvas do begin
Font := GridSuma.Font;
Pen.Color := clBlack;
if (ACol = 0) or (ARow = 0) then begin
{ Рисуем заголовок }
Brush.Color := clBtnFace;
FillRect(ARect);
TextOut(ARect.Left, ARect.Top, GridSuma.Cells[ACol, ARow])
end
else begin
{ Рисуем ячейку с правым выравниванием }
Brush.Color := clWhite;
FillRect(ARect);
dx := TextWidth (GridSuma.Cells[ACol, ARow]) + 2;
TextOut(ARect.Right - dx, ARect.Top, GridSuma.Cells[ACol, ARow])
end
end
end;

[001605]


Delphi 1

Манипуляция словами в TStringGrid

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
var s: String;
c: Byte;
begin
with StringGrid1 do
s := Cells[Col, Row];
if Length(s) = 0 then
begin
if Key in ['a'..'z'] then
begin
c := Ord(Key) - 32;
Key := Chr(c);
end;
exit;
end;
if s[Length(s)] = ' ' then
if Key in ['a'..'z'] then
begin
c := Ord(Key) - 32;
Key := Chr(c);
end;
end;

В обработчике события onKeyPress сделайте следующее:

if length(field.text) = 0 then key := upCase (key);

[001641]


Tabbednotebook и куча ресурсов

Тема: Как избежать использования кучи ресурсов (Resource Heap) при работе с TabbedNotebook

Данный документ расскажет о том, как с помощью Object Pascal можно управлять числом активных handlesWindows (оконных дескрипторов), в особенности кучей ресурсов пользователя (User Resource heap), а также следить за этими показателями. О чем этот документ? Попробую коротко и доходчиво: Windows следит за каждым элементом, имеющим фокус, через его дескриптор (Handle). Исходя из этого, Windows не может одновременно поддерживать несколько оконных дескрипторов (4-байтных указателей), и в этом совете мы приведем простой пример кода, позволяющего "легко" загружать ресурсы и обходить эти ограничения, встающие перед разработчиками Delphi.

USER DLL в действительности является библиоткой, распределяющей и поддерживающей ресурсы для всех окон и связанных структур данных, включая элементы управления, имеющие фокус, и другие неупомянутые объекты, но вместе с тем необходимо помнить, что эта библиотека работает под Windows. С этим связаны ограничения при работе с ресурсами USER DLL, и эта та проблема, над которой мы будем работать в этом совете. Данный пример добавляет загрузку ресурса для каждого элемента управления, добавляемого на форму, здесь мы берем 4 байта из кучи USER в 64К *.

Почему мы уверены в том, что у нас это получится? Мы будем разрушать** дескрипторы окон, которые Windows, согласно своей архитектуре, должна помнить. Разрушая эти дескрипторы, мы, таким образом, избегаем освобождения пользовательских (USER) ресурсов, это означает, что нам не нужно будет снова создавать вышеуказанные объекты. Наоборот, текущая архитектура VCL обладает способностью следить за вышеуказанными объектами, которые, в действительности, являются указателями на структуру. Так, зная, что VCL поддерживает дескриптор и windows создаст новый дескриптор КАК ТРЕБУЕТСЯ, то вместо поддержания постоянно одного дескриптора (как это подразумевалось при создании архитектуры Windows), мы можем управлять пользовательскими (USER) ресурсами вручную, позволяя разработчику легко загружать их по мере необходимости.

Данный пример демонстрирует работу с дескрипторами пользовательских (USER) ресурсов компонента Delphi TTabbedNoteBook (в части освобождения дескрипторов страниц), Delphi DestroyHandle (процедура TWinControl для удаления пользовательских (USER) дескрипторов), и работу вызова Windows API LockWindowUpdate (блокировка нежелательной перерисовки).

Технология освобождения дескриптора страницы TTabbedNoteBook может работать и с любыми потомками TWinControl. TWinControl - класс предка, который умеет создавать и разрушать оконные дескрипторы; CreateHandle & DestroyHandle.

* 64К для Win3.1 & 64К только для 16-битной подсистемы Win95. Для получения дополнительной информации обратитесь в Microsoft или к MSDN.
** Как побочный эффект при разрушении вышеописанных дескрипторов, TTabbedNotebook, используемый в данном примере, гораздо быстрее выполняет перемещение страниц.

Демонстрационный код

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

<Модуль с объявленными в нем TTabbedNotebook и TTimer>

...
Implementation

Type TSurfaceWin = class(TWinControl);

procedure TForm1.Timer1Timer(Sender: TObject);
begin
{Данный код заменяет заголовок формы на системную информацию,
содержащую в процентах free SYSTEM, GDI, &USER для windows.}
caption := 'SYSTEM: ' +
inttostr(getfreesystemresources(GFSR_SYSTEMRESOURCES)) +
' GDI: ' + inttostr(getfreesystemresources(GFSR_GDIRESOURCES)) +
' USER: ' + inttostr(getfreesystemresources(GFSR_USERRESOURCES));
end;

procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab:
Integer;  var AllowChange: Boolean);
begin
{LockWindowUpdate запрещает перерисовку данного окна}
LockWindowUpdate(handle);

{Причина использования TSurfaceWin в том, что вызов DestroyHandle в TWinControl объявлен как абстрактный, поэтому данный вызов возможен только его потомками, реализовавшими данную процедуру. Следующая строка читает индекс текущей страницы TabbedNotebook и разрушает ее дескриптор при перемещении на другую страницу. ПРИМЕЧАНИЕ: Даже если мы уничтожаем дескриптор, Windows помнит страничный объект и переназначает/создает новый при нажатии на другой закладке. }
 TSurfaceWin(TabbedNotebook1.pages.objects[tabbedNotebook1.pageindex]).DestroyHandle;

{Выключаем блокировку формы, чтобы любой элемент управления мог перерисовывать себя}
LockWindowUpdate(0);
end;

[001069]


Delphi 1

Доступ к страницам Tabbednotebook

При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook.

Вы можете сделать это следующим образом (пример дан для кнопки):

MyButton := TButton.Create( Form1 );  {как обычно...}
...
...
MyButton.Parent := TTabPage( TabbedNotebook1.Pages.Objects[n] );
{ <== где 'n' - индекс желаемой страницы ==> }

Свойство notebook 'Pages' имеет тип StringList и содержит список заголовков и объектов 'TTabPage'.

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

При добавлении компонента на страницу TabbedNotebook во время выполнения приложения, указатель на желаемую страницу для свойства Parent нового компонента должен быть назначен перед тем, как он будет реально показан. Способ получить доступ ко всем страницам TTabbedNotebook во время выполнения программы - с помощью свойства-массива Objects свойства TabbedNotebook Pages. Другими словами, страничные компоненты хранятся как объекты, присоединенные к имени страницы в списке строк свойства Pages. В следующим коде показано создание кнопки на второй странице компонента TabbedNotebook1:

var
NewButton : TButton;
begin
NewButton := TButton.Create(Self);
NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[1])
...

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

NewButton.Parent := TWinControl(Notebook1.Pages.Objects[1])

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

NewButton.Parent := TWinControl(TabSet1.Tabs.Objects[1])

[001451]


Delphi 1

Разделяемые элементы управления для Tabbednotebook I

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

Что делаю я -- располагаю разделяемые элементы управления на форме, а не на конкретной странице TTabbedNotebook. Для того, чтобы сделать это, вам необходимо установить свойство TTabbedNotebook Align на что-то другое, отличное от alClient -- например, если разделяемые элементы управления расположены в нижней части формы, используйте для TTabbedNotebook значение alTop, и отодвиньте нижнюю границу чуть повыше, чтобы в образовавшейся области без труда разместились бы разделяемые элементы управления.

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

У меня это работает. Я еще не испытывал нужду в разделяемых элементах управления для _набора_ страниц, но первая идея, которая приходит мне в голову, заключается в установке свойства Visible для каждого компонента в true/false в обработчике события TTabbedNotebook OnChange. [001596]


Delphi 1

Разделяемые элементы управления для Tabbednotebook II

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

Для любых закладок, где разделяемые компоненты НЕ должны появляться, установите их свойство Visible в False, сделать это лучше всего в обработчике события TabbedNotebook OnChange. [001609]


Delphi 1

Разделяемые элементы управления для Tabbednotebook III

Компоненты, которые вы хотите показывать на всех страницах, должны принадлежать родителю TTabbedNotebook (в общем случае TForm, на которой расположен компонент), и, очевидно, они должны быть размещены ПОЗАДИ TTabbedNotebook. Самым простым способом сделать это, как я выяснил, является следующий способ: разместите на форме TTabbedNotebook, но оставьте возможность задать ему родителя (например, пока не устанавливайте ему свойство .Align), затем разместите кнопки (или что там у вас) в области родителя, затем установите свойство .Align у TTabbedNotebook, после чего элементы управления, которые вы разместили, окажутся позади TTabbedNotebook, и будут видны на всех его страницах (действительно, они будут располагаться "наверху" TTabbedNotebook. Если вы уже разместили компоненты, то лучшим решением будет использование для TTabbedNotebook команды меню "Edit/Send to Back", при котором нижние компоненты "всплывут" наверх. Также, возможно непосредственно отредактировать файл .DFM и убедиться в том, что родительский порядок компонентов собледен в полной мере. [001611]


Над какой закладкой курсор?

YoungHacker советует:

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

function Form1.ItemAtPos(TabControlHandle : HWND; X, Y : Integer) : Integer;
var
HitTestInfo : TTCHitTestInfo;
HitIndex : Integer;
begin
HitTestInfo.pt.x := X;
HitTestInfo.pt.y := Y;
HitTestInfo.flags := 0;
HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo));
Result := HitIndex;
end;

[001030]


Delphi 3

Создание таблицы в модуле

Объект TTable может быть создан с владельцем, а может и без оного. Поскольку вы объявляете его локально в процедуре, то владелец в этом случае не требуется. Если владелец не задан, то забота об освобождении объекта ложится на вас. В противном случае объект освобождается владельцем всякий раз, когда освобождается сам владелец. Имеет смысл? Чтобы создать таблицу без владельца, сделайте следующее:

procedure CreateATableInAUnit;
var
myTable : TTable;
begin
myTable := TTable.Create(nil);
try
myTable.DatabaseName := 'MyDB';
myTable.TableName := 'MyTable.db';
mytable.IndexName := 'MyIndex';
myTable.Open;
{другой код}
finally
myTable.Free;
end;
end;

[001237]


Delphi 1

Изменение количества закладок в TTabSet во время выполнения программы

Вначале сделайте где-то в вашем коде следующее объявление:

TabSet1: TTabSet;  { подразумевается, что это принадлежит Form1 }

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

Form1.TabSet1.Tabs.Clear;

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

Form1.TabSet1.Tabs.Add('какой-то заголовок');

Пожалуйста, помните о том, что я назначил имя в предположении, что вы имеете ссылку на юнит, где оно определено [но не исключаю возможности, что вы можете получить ссылку на закладку и через обработчика соответствующего события, что еще проще, но мы то с вами должны знать все!]. Если вам нужно сослаться на объект из другого модуля, просто добавьте к вызову имя модуля (и добавьте этот модуль в список "uses"), например так:

Unit1.Form1.TabSet1.Tabs.Add('Заголовок');

Поскольку "TabSet1.Tabs" имеет тип TStrings, вы можете использовать любой из доступных методов этого типа (AddObject, LoadFromFile и т.д.). [001472]


Delphi 2

Синхронизация TabSet c ListBox

Что-то аналогичное я делал раньше, тем не менее, вместо Listbox я использовал dbGrid со следующими опциями:

[dgAlwaysShowEditor,dgTabs,dgRowSelect,dgAlwaysShowSelection,dgConfirmDelete, dgCancelOnExit]

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

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
Table1.FindNearest([Chr(NewTab+65)]);
Table2.FindNearest([Chr(NewTab+65)]);
end;

procedure TForm1.TabSet1Click(Sender: TObject);
var
I: integer;
begin
with TabSet1 do
begin
if TabIndex > -1 then
begin
with ListBox1 do
begin
for I := 0 to Items.Count - 1 do
begin
if Pos(Tabs[TabIndex], Items[I]) = 1 then
begin
ItemIndex := I;
break;
end;
end;
end;
end;
end;
end;

[001607]


Delphi 1

Остановка таймера на `полпути`

Timer1.Enabled := False;
Timer1.Enabled := True;

Это полностью "сбрасывает" таймер, другими словами, перезапускает его.

BTW: изменение интервала (в другое значение) также производит сброс таймера.

Вы можете включать и выключать ваш таймерный компонент, устанавливая соответствующее свойство, например::

Timer1.Enabled := True; { или False, если вы хотите выключить его }

Но при этом свои 5 секунд таймер продолжает отсчитывать. Если вы хотите изменить это, присвойте ему другой интервал, например так:

Timer1.Interval := 100;

[001408]


Delphi 1

Некоторые вопросы про таймер

Interval определен как word, поэтому значение 65,535 является максимальным для данного свойства. Не знаю насчет других компонентов, но для использования таймера с интервалом больше минуты, рекомендую следующий код:

var
numOfMinutes: integer;
...
numOfMinutes := 30;
timer1.interval := 60000;
timer1.enabled := true;
...
procedure Timer1Timer;
begin
dec (numOfMinutes);
if numOfMinutes = 0 then begin
{ делайте все, что вы хотели сделать }
end;
end;

unit Alarm;

{
Авторские права (c) 1996 Eric Nielsen. Все права защищены.

Разрешено использовать, копировать, изменять и распространять
для НЕКОММЕРЧЕСКИХ или КОММЕРЧЕСКИХ целей, но без гарантии.
}
interface

uses
SysUtils, WinTypes, WinProcs, StdCtrls, Controls, Classes, ExtCtrls, Forms;

type
TForm1 = class(TForm)
Timer1: TTimer;
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Edit1: TEdit;
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure FormAlarm(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
type
TAlarm=class(TComponent)
private
FAlarmTime : TDateTime;
FOnAlarm: TNotifyEvent;
FTimer : TTimer;
FEnabled : Boolean;
procedure SetOnAlarm(Value: TNotifyEvent);
procedure SetEnabled(Value: Boolean);
procedure SetAlarm(Value: TDateTime);
procedure AlarmTimer(Sender: TObject);
protected
procedure Alarm; dynamic;
procedure UpdateAlarm;
public
property AlarmTime : TDateTime read FAlarmTime write SetAlarm;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnAlarm: TNotifyEvent read FOnAlarm write SetOnAlarm;
property Enabled: Boolean read FEnabled write SetEnabled default False;
end;

procedure TAlarm.SetOnAlarm(Value: TNotifyEvent);
begin
FOnAlarm := Value;
UpdateAlarm;
end;

procedure TAlarm.SetEnabled(Value : Boolean);
begin
FEnabled := Value;
UpdateAlarm;
end;

procedure TAlarm.SetAlarm(Value: TDateTime);
begin
FAlarmTime := Value;
UpdateAlarm;
end;

procedure TAlarm.Alarm;
begin
If Assigned(FOnAlarm) then FOnAlarm(Self);
end;

procedure TAlarm.UpdateAlarm;
begin
If Assigned(FOnAlarm) and FEnabled
Then
FTimer.Enabled := True
Else
FTimer.Enabled := False;
end;

constructor TAlarm.Create(AOwner: TComponent);
begin
FTimer := TTimer.Create(Self);
With FTimer do
Begin
Enabled := False;
Interval := 250;
OnTimer := AlarmTimer;
End;
end;

destructor TAlarm.Destroy;
begin
FEnabled := False;
UpdateAlarm;
FTimer.Free;
end;

procedure TAlarm.AlarmTimer(Sender: TObject);
begin
If Now >= FAlarmTime
Then
Alarm;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := DateTimeToStr(Now);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label2.Caption := 'Ожидание...';
With TAlarm.Create(Self) do
begin
AlarmTime := StrToDateTime(Edit1.Text);
OnAlarm := FormAlarm;
Enabled := True;
end;
end;

procedure TForm1.FormAlarm(Sender: TObject);
begin
(Sender as TAlarm).Free;
Label2.Caption := 'Бииииип!';
end;

end.

[001628]


Письмо читателя

Как можно обойтись без Ttimer и наиболее рационально использовать ресурсы системы?

Олегом Кулабухов отвечает:

procedure Delay(ms : longint);
var
TheTime : LongInt;
begin
TheTime := GetTickCount + ms;

while GetTickCount < TheTime do
Application.ProcessMessages;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start Test');
Delay(2000);
ShowMessage('End Test');
end;

[001794]


Письмо читателя

TrackBar для эстетов

В стандартном компоненте всегда присутствует диапазон выбора (см. на рисунке нижний TrackBar). К сожалению, в DELPHI не предусмотрена возможность его отключения. Если нет необходимости в использовании диапазона выбора, то поможет небольшая доработка компонента.

unit NTrackBar;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;

type
TNTrackBar = class(TTrackBar)
private
FSelRangeVisible: Boolean;
procedure SetSelRangeVisible(const Value: Boolean);
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property SelRangeVisible: Boolean read FSelRangeVisible write SetSelRangeVisible;
end;

procedure Register;

implementation

{ TNTrackBar }
constructor TNTrackBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSelRangeVisible:= False;
ThumbLength:= 18;
end;

procedure TNTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do begin
if not FSelRangeVisible then Style:= Style xor TBS_ENABLESELRANGE
else Style:= Style or TBS_ENABLESELRANGE;
end;
end;

procedure TNTrackBar.SetSelRangeVisible(const Value: Boolean);
begin
if FSelRangeVisible <> Value then begin
FSelRangeVisible:= Value;
RecreateWnd;
end;
end;

procedure Register;
begin
RegisterComponents('Controls', [TNTrackBar]);
end;

end.

C уважением, VS [001692]


Delphi 2

Поточность TreeView

На пустой форме у меня располагается TTreeView. Затем я сохраняю это в файле, используя WriteComponent. Это работает как положено; я могу из DOS c помощью команды "type" посмотреть двоичный файл и увидеть его содержимое, типа строк TTreeView и имя объекта. По крайней мере файл записывается и создается впечатление его "наполненности".

Затем я освобождаю компонент TTreeView, открываю поток, делаю ReadComponent и, затем, InsertControl. И получаю исключение "TreeView1 has no parent window" (TreeView1 не имеет родительского окна).

Это происходит из-за того, что при установке определенных свойств TreeView требуется дескриптор окна элемента управления, а для этого необходимо иметь родителя. Решение заключается в создании пустого TreeView и передаче его в качестве параметра ReadComponent - вы наверняка меня спросите, почему ReadComponent необходим параметр, правильно? Смотрите дальше.

Попробуйте этот код:

procedure TForm1.Button1Click(Sender: TObject);
var TreeView : TTreeView ;
begin
with TFileStream.Create( 'JUNK.STR', fmCreate ) do try
WriteComponent( TreeView1 ) ;
TreeView1.Name := 'TreeView' ;
Position := 0 ;
TreeView := TTreeView.Create( Self ) ;
TreeView.Visible := false ;
TreeView.Parent := Self ;
ReadComponent( TreeView ) ;
TreeView.Top := TreeView1.Top + TreeView1.Height + 10 ;
TreeView.Visible := true ;
finally
Free ;
end ;
end;

Два небольших замечания:

  1. Убедитесь в отсутствии конфликта имен. Данный код делает форму владельцем второго TreeView и при ее освобождении разрушает компонент. Я просто переименовываю существующий TreeView перед загрузкой 'клона'.
  2. Я установил свойство visible в false перед установкой свойства parent, этим я предотвратил показ только что созданного TreeView до момента загрузки его из потока.
- Mike Scott [001005]


Delphi 2

Получение доступа к узлам TreeView

Небольшие хитрости для работы с узлами TreeView:

Если вы хотите производить поиск по дереву, может быть для того, чтобы найти узел, соответствующий определенному критерию, то НЕ ДЕЛАЙТЕ ЭТО ТАКИМ ОБРАЗОМ:

for i := 0 to pred(MyTreeView.Items.Count) do
begin
if MyTreeView.Items[i].Text = 'Банзай' then
break;
end;

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

Значительно быстрее будет так:

Noddy := MyTreeView.Items[0];
Searching := true;
while (Searching) and (Noddy <> nil) do
begin
if Noddy.text = SearchTarget then
begin
Searching := False;
MyTreeView.Selected := Noddy;
MyTreeView.SetFocus;
end else
begin
Noddy := Noddy.GetNext
end;
end;

В моей системе приведенный выше код показал скорость 33 милисекунды при работе с деревом, имеющим 171 узел. Первый поиск потребовал 2.15 секунд.

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

Вам действительно не нужно просматривать все дерево, чтобы найти что вам нужно - получить таким образом доступ к MyTreeView.Items[170] займет много больше времени, чем получения доступа к MyTreeView.Items[1].

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

    "Свойство ItemId является дескриптором TTreeNode типа HTreeItem
    и однозначно идентифицирует каждый элемент дерева. Используйте
    это свойство, если вам необходимо получить доступ к элементам
    дерева из внешнего по отношению к TreeView элемента управления."
"Я разговаривал с деревьями...вот почему они ушли от меня...." (Spike Milligan)..

- Peter Kane [001039]


Хочется выделять некотоpые стpочки в TTreeView жиpным или бледным. Как?

Nomadic советует:

Гpхм... Господа, но если pечь пpо bold... Матчасть yчить надо 8-).

procedure SetNodeState(node :TTreeNode; Flags: Integer);
var
tvi: TTVItem;
begin
FillChar(tvi, Sizeof(tvi), 0);
tvi.hItem := node.ItemID;
tvi.mask := TVIF_STATE;
tvi.stateMask := TVIS_BOLD or TVIS_CUT;
tvi.state := Flags;
TreeView_SetItem(node.Handle, tvi);
end;

И вызываем:

SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жиpным
SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконкy бледной

(Ctrl+X)

SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жиpным
SetNodeState(TreeView1.Selected, 0); // Hи того, ни дpyгого

Когда-то (мечтательно закатив глаза в потолок) в API было еще и TVIS_DISABLE. Снесли собаки. А pекомендyемyю стилистикy yпотpебления этого добpа смотpи в MS Internet News. [001191]


Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?

Nomadic советует:

unit BetterTreeView;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;

type
TTVNewEditCancelEvent = procedure( Sender: TObject;
Node: TTreeNode; var Delete: Boolean) of object;
TBetterTreeView = class(TTreeView)
protected
FIsEditingNew: Boolean;
FOnEditCancel: TTVChangedEvent;
FOnNewEditCancel: TTVNewEditCancelEvent;
procedure Edit(const Item: TTVItem); override;
public
function NewChildAndEdit(Node: TTreeNode; const S: String)
: TTreeNode;
published
property IsEditingNew: Boolean read FIsEditingNew;
property OnEditCancel: TTVChangedEvent
read FOnEditCancel write FOnEditCancel;
property OnNewEditCancel: TTVNewEditCancelEvent
read FOnNewEditCancel write FOnNewEditCancel;
end;

implementation

procedure TBetterTreeView.Edit(const Item: TTVItem);
var
Node: TTreeNode;
Action: Boolean;
begin
with Item do begin
{ Get the node }
if (state and TVIF_PARAM) <> 0 then
Node := Pointer(lParam)
else
Node := Items.GetNode(hItem);

if pszText = nil then begin
if FIsEditingNew then begin
Action := True;
if Assigned(FOnNewEditCancel) then
FOnNewEditCancel(Self, Node, Action);
if Action then
Node.Destroy
end
else
if Assigned(FOnEditCancel) then
FOnEditCancel(Self, Node);
end
else
inherited;
end;
FIsEditingNew := False;
end;

function TBetterTreeView.NewChildAndEdit
(Node: TTreeNode; const S: String): TTreeNode;
begin
SetFocus;
Result := Items.AddChild(Node, S);
FIsEditingNew := True;
Node.Expand(False);
Result.EditText;
SetFocus;
end;

end.

[001612]


Как убрать всплывающие подсказки в TreeView?

Nomadic отвечает:

TCustomTreeView.WMNotify. О том, что такое тип notify'а TTM_NEEDTEXT пpочтешь в хелпе. Убpать хинты можно, пеpекpыв обpаботчик для этого уведомительного сообщения. [001620]


Delphi 2

Ускорение работы TreeView II

Try
LockWindowUpdate(TreeView1.Handle);
...
finally
LockWindowUpdate(0);

Выключите свойство сортировки (установите sort в off).

Я много работаю с TTreeView. За раз обычно я манипулирую сотнями, а то и тысячами узлов. Для сокращения времени обработки воспользуйтесь моим опытом и советами:

  • Используйте TreeView1.BeginUpdate и TreeView1.EndUpdate перед и после того, как делаете много изменений и добавлений.
  • Установите SortType на stNone по умолчанию. (Запрещаем дереву делать автоматическую сортировку при каждом добавлении или изменении узлов. Это, вероятно, будет самой большой экономией временных затрат.)
Если вам необходимо отсортировать ваши узлы, то сохранить время сортировки можно сортировкой только в случае их видимости. Поскольку вы добавляете элементы к дереву сами, вы можете решить выбрать сортировку по умолчанию, а сортировать только детей (при раскрытии родительского узла). Вот как это я делаю в обработчике события OnExpanded:

procedure TForm1.TreeView1Expanded(Sender: TObject; Node: TTreeNode);
begin
Node.Alphasort;  {Сортируем дочерние узлы и -только- дочерние узлы}
end;

Данный код позаботится о сортировки каждого уровня, кроме корневого. Я не знаю способа сообщить TTreeView о необходимости сортировки только корневых узлов. TreeView1.Alphasort сортирует -каждый- элемент дерева (тратится много времени). Если вам нужно сортировать элементы корневого уровня, не сортируя все узлы дерева, вы должны делать это сами. Вероятно, необходимо начать с QuickSort или InsertionSort, и метода TTreeNode.MoveTo.

Поместите ваш код для работы с TreeView между вызовами TreeView1.Items.BeginUpdate и TreeView1.Items.EndUpdate. И убедитесь в том, что дерево неотсортировано. [001630]


Delphi 2

Сохранение содержимого TreeView

Сохраняем:

MyTreeView.SaveToFile('Filename');

Читаем:

MyTreeView.LoadFromFile('Filename');

Проблема: Данный метод сохраняет только имена элементов и структуру (при сохранении файл получается текстовым, с отражением структуры). Метод не сохраняет свойство ImageIndex и другие. После "LoadFromFile" необходимо восстановить исходные иконки. [001708]


Письмо читателя

Как сделать так, чтобы в TreeView текущий Node выделялся другим шрифтом, типа Underline и т.д.?

Nomadic отвечает:

procedure TForm1.TreeView1CustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
if cdsSelected in State then
begin
Sender.Canvas.Font.Style := Sender.Canvas.Font.Style + [fsUnderline];
end;
end;

[001747]


Что нужно знать о принципе и порядке работы с TUpdateSQL для работы с неживыми запросами?

Nomadic советует:

Кидаешь UpdateSQL на форму, после чего в том SQL, который ты собираешься редактировать, устанавливаешь в UpdateObject имя этого UpdateSQL. После этих дел по дабл-клику на UpdateSQL выдаётся редактор, в котором ты должен для каждой из таблиц,входящих в твой запрос, указать набор полей, являющихся уникальным ключём таблицы, и набор полей, которые требуется редактировать. В общем случае возможны глюки с редактированием, если в числе изменяемых полей будут элементы ключа. Указав все поля, давишь кнопку Generate SQL и в результате у тебя генерятся запросы на редактирование, добавление и удаление, которые прописываются в том же UpdateSQL. Обычно эти запросы никакого дополнительного редактирования не требуют. После всех этих дел ты можешь нормально редактировать запрос, как обычную таблицу.

Hекоторые моменты.

Для того, чтобы всё это нормально работало, нужно, чтобы в TQuery были включены RequestLive и CashedUpdates. Соответственно, для подтверждения изменений нужно вызывать TQuery.ApplyUpdates и TQuery.CommitUpdates, либо TDatabase.ApplyUpdates, а для отмены - CancelUpdates.

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

-- Отрезано --

Hасчёт CachedUpdates.

Сия хреновина придумана для того, чтобы обеспечить сохранение/отмену редактирования/добавления/удаления сразу нескольких записей. Принцип совершенно элементарен: если CachedUpdates включен, то все производимые изменения в датасете по команде Post фиксируются не в базе, а во временном файле на винте клиента. Для того, чтобы прописать изменения в таблице (физически), необходимо вызвать для соответствующего запроса последовательно методы ApplyUpdates и CommitUpdates, а для отмены ВСЕХ изменений (начиная от последнего выполненного CommitUpdates), вызвать CancelUpdates. Кроме того, метод ApplyUpdates у TDataBase. Этому методу нужен список датасетов, и он производит их обновление в одной транзакции.

Практическое применение, например, такое: на форме редактирования с гридом и набором кнопок Добавить, Удалить, Редактировать, ОК, Отмена, вешаешь на первые три кнопки обработчики с Insert, Delete и Edit соответственно, на ОК - такой примерно обработчик:

with DataSet do begin
if State in [dsEdit,dsInsert] then Post;
ApplyUpdates;
CommitUpdates;
end;

а на Отмену такой:

with DataSet do begin
if State in [dsEdit,dsInsert] then Cancel;
CancelUpdates;
end;

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

Лучше использовать конструкцию "State in dsEditModes" [001330]


Письмо читателя

Как у TWebBrowser (IE4 ActiveX) показать диалог Find?

Nomadic советует:

  1. Диалог Find у IE4 сделан через JScript. Этот скрипт лежит в ресурсах mshtml.dll и зовется find.dlg. Вызывается через showHTMLDialog. Вся тонкость в передаче параметров (я немного упростил оригинальный find.dlg и передаю их через SafeArray а не через IDispatch). Вот основная часть кода:

    [...]
    ...
    {$R HTMLdlg.res}
    ...
    procedure     TForm1.ToolButton1Click(Sender: TObject);
    var Disp: IDispatch;
    Doc: IHTMLDocument2;
    Wnd: IHTMLWindow2;
    hr: HResult;
    hinstMSHTML: Longint;
    pfnShowHTMLDialog: SHOWHTMLDIALOGFN;
    szTemp: array [0..MAX_PATH-1] of Char;
    bstr: array [0..MAX_PATH-1] of WideChar;
    pmk: IMoniker;
    varArgs, varReturn: OleVariant;
    begin
    Disp:=IE4.Document;
    hr:=Disp.QueryInterface(IID_IHTMLDocument2, Doc);
    Disp._Release;
    if (hr=S_OK) then begin
    hinstMSHTML:=LoadLibrary('MSHTML.DLL');
    if (hinstMSHTML>0) then begin
    pfnShowHTMLDialog:=GetProcAddress(hinstMSHTML, 'ShowHTMLDialog');
    if Assigned(pfnShowHTMLDialog) then begin
    StrCopy(szTemp, 'res://');
    GetModuleFileName(hInstance, szTemp + lstrlen(szTemp),
    Length(szTemp) - lstrlen(szTemp));
    StrCat(szTemp, '/HTML_RESOURCE');
    MultiByteToWideChar(CP_ACP, 0,  szTemp, -1, bstr, length(bstr));
    CreateUrlMoniker(nil, bstr, pmk);
    if Assigned(pmk) then begin
    Wnd:=Doc.Get_parentWindow;
    VarArgs:=VarArrayOf([Wnd, Doc, 'VARIANT']);
    varReturn:=Unassigned;
    hr:=pfnShowHTMLDialog(0, pmk, varArgs, nil, varReturn);
    //Wnd._Release;
    //pmk._Release;
    if SUCCEEDED(hr)
    then ShowMessage(varReturn);
    end;
    end;
    FreeLibrary(hinstMSHTML);
    end;
    //     Doc._Release;
    end;
    end;

    [...]

  2. еще пример:

    uses ActiveX;

    const
    CGID_FuckIE4: TGUID = '{ed016940-bd5b-11cf-ba4e-00c04fd70816}'; // UNDOCUMENTED
    CGID_MSHTML: TGUID = '{DE4BA900-59CA-11CF-9592-444553540000}'; // DOCUMENTED IE5+
    IDM_FIND = 67;

    procedure TfWebReport.acReportFindExecute(Sender: TObject);
    var
    A, B: OleVariant;
    Target: IOleCommandTarget;
    OleCmd: TOLECMD;
    begin
    // wbMain - это TWebBrowser
    Target := wbMain.Document as IOLECommandTarget;
    with OleCmd do begin
    cmdId := IDM_FIND;
    cmdf  := 0;
    end;
    Target.QueryStatus(@CGID_MSHTML, 1, @OleCmd, NIL);
    if (OleCmd.cmdf and OLECMDF_SUPPORTED) <> 0 then
    // We have IE5+ use documented manner
    Target.Exec(@CGID_MSHTML, IDM_FIND, OLECMDEXECOPT_DODEFAULT, A, B)
    else
    // We have not IE5+ :-(, use undocumented feature
    Target.Exec(@CGID_FuckIE4, 1, OLECMDEXECOPT_DODEFAULT, A, B);
    end;

[001720]


Создание компонентов для работы с базами данных

Тема: Создание компонентов для работы с базами данных, позволяющих работать с самими данными

Обзор

Данный документ описывает минимально необходимые шаги, необходимые для создания компонента для работы с базами данных, который может отображать данные отдельного поля. Примером такого компонента может служить панель со свойствами DataSource и DataField, похожая на компонент TDBText. Для получения дополнительных примеров обратитесь к Руководству по написанию компонентов "Making a Control Data-Aware".

Как пользоваться данным документом

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

  • создание компонентов на основе существующих

  • перекрытие конструкторов и деструкторов

  • создание новых свойств

  • чтение и запись значений свойств

  • назначение обработчиков событий

Основные шаги по созданию компоненты, осуществляющей навигацию по данным

  • Создайте или наследуйте компонент, который допускает свое отображение, но не ввод данных. Например, вы могли бы использовать компонент TMemo с установленным в True свойством ReadOnly. В примере, приведенном в данном документе, мы используем TCustomPanel. TCustomPanel позволяет себя отображать, но не вводить данные.

  • Добавьте к вашему компоненту data-link object (объект для связи с данными). Данный объект позволяет управлять связью между компонентом и таблицей базы данных.

  • Добавьте к компоненту свойства DataField и DataSource.

  • Добавьте методы для получения и установления DataField и DataSource.

  • Добавьте к компоненту метод DataChange, позволяющий управлять событиями OnDataChange объекта data-link.

  • Перекройте конструктор компонента для создания datalink и перехвата метода DataChange.

  • Перекройте деструктор компонента для очищения datalink.

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

    Выберите соответствующий пункт меню для создания нового компонента (он меняется от версии к версии Delphi), определите TDBPanel как имя класса, и TCustomPanel в качестве наследуемого типа. Определите любую страницу Палитры компонентов.

  • Добавьте DB и DBTables в список используемых модулей.

  • Добавьте data-link объект в секцию private вашего компонента. Данный пример отображает данные одного поля, поэтому мы используем TFieldDataLink для обеспечения связи между нашим новым компонентом и DataSource. Имя нового data-link объекта - FDataLink.

    { пример }
    private
    FDataLink: TFieldDataLink;

  • Добавьте к компоненту свойства DataField и DataSource. Мы добавим соответствующий код для методов записи/чтения в последующих шагах.

    Примечание: Наш новый компонент будет иметь свойства DataField и DataSource, FDataLink также будет иметь собственные свойства DataField и Datasource.

    { пример }
    published
    property DataField: string
    read   GetDataField
    write  SetDataField;
    property DataSource: TDataSource
    read   GetDataSource
    write  SetDataSource;

  • Добавьте частные методы для чтения/записи значений свойств DataField и DataSource, и свойств DataField и DataSource для FDataLink.

    { пример }
    private
    FDataLink: TFieldDataLink;
    function GetDataField: String;
    function GetDataSource: TDataSource;
    procedure SetDataField(Const Value: string);
    procedure SetDataSource(Value: TDataSource);
    .
    .
    implementation
    .
    .
    function TDBPanel.GetDataField: String;
    begin
    Result := FDataLink.FieldName;
    end;

    function TDBPanel.GetDataSource: TDataSource;
    begin
    Result := FDataLink.DataSource;
    end;

    procedure TDBPanel.SetDataField(Const Value: string);
    begin
    FDataLink.FieldName := Value;
    end;

    procedure TDBPanel.SetDataSource(Value: TDataSource);
    begin
    FDataLink.DataSource := Value;
    end;

  • Добавьте частный метод DataChange, назначая событие объекта datalink OnDataChange. В методе DataChange добавьте код для отображения данных поля актуальной базы данных, связь с которой обеспечивает объект data-link. В нашем примере мы назначаем значение поля FDataLink заголовку панели.

    { пример }
    private
    .
    .
    procedure DataChange(Sender: TObject);

    implementation
    .
    .
    procedure TDBPanel.DataChange(Sender: TObject);
    begin
    if FDataLink.Field = nil then
    Caption := '';
    else
    Caption := FDataLink.Field.AsString;
    end;

  • Перекройте метод конструктора компонента Create. При реализации Create, создайте объект FDataLink и назначьте частный метод DataChange событию FDataLink OnDataChange.

    { пример }
    public
    constructor Create(AOwner: TComponent); override;
    .
    .
    implementation
    .
    .
    constructor TMyDBPanel.Create(AOwner: TComponent);
    begin
    inherited Create(AOwner);
    FDataLink := TFieldDataLink.Create;
    FDataLink.OnDataChange := DataChange;
    end;

  • Перекройте метод деструктора компонента Destroy. При реализации Destroy, установите OnDataChange в nil (чтобы избежать GPF), и освободите FDatalink.

    { пример }
    public
    .
    .
    destructor Destroy; override;
    .
    .
    implementation
    .
    .
    destructor TDBPanel.Destroy;
    begin
    FDataLink.OnDataChange := nil;
    FDataLink.Free;
    inherited Destroy;
    end;

  • Сохраните модуль и установите компонент (смотрите документацию Users Guide и Component Writers Guide для получения дополнительной информации по сохранению модулей и установке компонентов).

  • Для тестирования функциональности компонента расположите на форме компоненты TTable, TDatasource, TDBNavigator и TDBPanel. Установите TTable DatabaseName и Tablename в 'DBDemos' и 'BioLife', а свойство Active в True. Установите свойство TDatasource Dataset в Table1. Установите TDBNavigator и свойство TDBPanel DataSource в Datasource1. Имя TDBpanel DataField должно быть установлено в 'Common_Name'. Запустите приложение и, используя навигатор и перемещаясь по записям, убедитесь в том, что TDBPanel обнаруживает изменение данных и отображает значение соответствующего поля.

Полный код компонента

unit Mydbp;

interface

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

type
TDBPanel = class(TCustomPanel)
private
FDataLink: TFieldDataLink;
function GetDataField: String;
function GetDataSource: TDataSource;
procedure SetDataField(Const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure DataChange(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property DataField: string
read   GetDataField
write  SetDataField;
property DataSource: TdataSource
read   GetDataSource
write  SetDataSource;
end;

procedure Register;

implementation

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

function TDBPanel.GetDataField: String;
begin
Result := FDataLink.FieldName;
end;

function TDBPanel.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;

procedure TDBPanel.SetDataField(Const Value: string);
begin
FDataLink.FieldName := Value;
end;

procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
end;

procedure TDBPanel.DataChange(Sender: TObject);
begin
if FDataLink.Field = nil then
Caption := ''
else
Caption := FDataLink.Field.AsString;
end;

constructor TDBPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;

destructor TDBPanel.Destroy;
begin
FDataLink.Free;
FDataLink.OnDataChange := nil;
inherited Destroy;
end;

end.

[001083]


Delphi 1

Динамическое создание компонент во время работы приложения

Использовать формы и компоненты Delphi очень просто. Если управлять этими объектами посредством Инспектора Объектов, то эту задачу можно отнести к числу тривиальных. Динамически создать объект также несложно. В этом документе мы обсудим некоторые вопросы, касающиеся динамического создания компонент во время работы приложения.

(вам следует помнить, что понятие "динамическое" весьма субъективно, поскольку Delphi все объекты создает динамически. Информация, предоставленная здесь - для программиста, который сам собирается создавать/менять свойства/разрушать объекты во время выполнения программы)

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

Конструктор Create() является классовым методом, наследуемым от класса TObject. Create() возвращает указатель. Данный метод может потребовать (а может и нет) один или несколько параметров. В большинстве компонентов (все объекты, наследуемые от TComponent, имеют право называться компонентами), конструктор на входе требует один параметр, указывающий на "владельца" и имеющий тип TComponent.

При динамическом создании компонента в большинстве случаев владелецем становится "Self". Если вы в этот момент находитесь в одном из методов формы, "Self" в данном контексте будет ссылаться на саму форму. Если владелец является действительным объектом, освобождение этого объекта влечет за собой автоматическое освобождение "дочернего" компонента. Другим распространенным параметром является "Application". Он может использоваться в случае, когда визуальный компонент не должен быть показан программой пользователю. Тем не менее, большинство компонентов не требуют назначения владельца, так что нет ничего необычного в том, что требуемый параметр owner устанавливается в Nil. Но вы должны помнить о том, что впоследствии вы не сможете изменить владельца объекта. Если конструктору при создании был передан Nil, то после использования компонента вы должны сами освобождать его вызовом Free.

После создания оконных компонентов (т.е. тех компонентов, которые являются наследниками TWinControl), но еще перед тем, как они будут отображены, у них необходимо установить свойство Parent. Место установки свойства Parent является хорошим местом для установки других свойств экземпляра данного компонента, включая обработчики событий (например, Width, Color, OnClick).

Обработчики событий идентичны тем, которые определены в Инспекторе Объектов. Просто присвойте имени свойства компонента для события, которое вы хотите обработать, имя метода обработчика события, которое вы ожидаете. В примере 1, приведенном ниже, при нажатии на кнопку будет вызван метод с именем "myclick". Пожалуйста имейте в виду, что список входных параметров одного метода должен в точности соответствовать списку выходных параметров другого.

Пример 1:

var
b1 : TButton;
begin
.
.
.
b1 := TButton.Create(Self);
with b1 do begin
Left := 20;
Top := 20;
Width := 90;
Height := 50;
Caption :=  'моя кнопка';
Parent := Form1;
OnClick :=  MyClick;  { процедура, определенная где-то еще }
end;
.
.
.
end;

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

unit Unit1;
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 }
procedure myClick(Sender: TObject);
end;

var
Form1: TForm1;

const
i : integer = 0;

implementation
{$R *.DFM}

procedure TForm1.myClick(Sender: TObject);
begin
with Sender as TButton do
Self.Caption := ClassName + ' ' + Name;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
with TButton.Create(self) do begin
Left := 20;
Top := 30 + i;
Width := 120;
Height := 40;
Name := 'ThisButton' + IntToStr(i);
Caption := 'There' + IntToStr(i);
OnClick := MyClick;  { процедура, определенная где-то еще }
Parent := Form1;
end; {end with}
inc(i, 40);
end; {end button1.click}
end.

[001162]


Delphi 1

Решение для динамически создаваемых компонентов

Предупреждение:
Если вы просто хотите во время выполнения приложения создавать компоненты необходимого вам типа, ознакомьтесь с файлом delphi\doc\VB2Delph.wri и следуйте его рекомендациям, лучшего способа изучения этой темы пока не существует. Данный совет повествует об использовании в Delphi RTTI.

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

Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterClasses([TButton, TEdit, TMemo, TLabel]);
end;

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

Создание компонентов. Используйте функцию FindClass() для получения ссылки на класс компонента, который вы хотите создать, и вызывайте его метод Create. Легко, не правда ли? В примере у меня имеется приведение типа SomeComponent к TControl, после чего я уже могу установить свойство parent (я могу делать это, поскольку я знаю, что все зарегистрированные мною классы являются потомками TControl). Для того, чтобы визуальный компонент появился на форме, вам необходимо установить свойство parent.

Пример:

procedure TForm1.CreateClick(Sender: TObject);
begin
SomeComponent:= TComponentClass(FindClass(ClassName.Text)).Create(Self);
(SomeComponent as TControl).Parent := Self;
end;

Теперь, когда вы имеете созданный компонент, как установить его свойства без использования самого большого блока case во вселенной? Очень просто: для получения информации о свойстве из структуры run-time type information (RTTI) используется функция GetPropInfo(), после чего для установления значений используется набор функций SetXXXXProp(). (Примечание: эти функции не задокументированы в файлах помощи Delphi. OO-программисты, как я понимаю, пользуются примерами из чужого кода и не изобретают свой велосипед.) У каждой функции SetXXXXProp() имеется функция-сателлит GetXXXXProp(), позволяющая узнать значения свойств объекта.

Пример:

procedure TForm1.SetPropertyClick(Sender: TObject);
var
PropType: PTypeInfo;
PropInfo: PPropInfo;
begin
PropInfo := GetPropInfo(SomeComponent.ClassInfo, PropertyName.Text);
PropType := PropInfo^.PropType;
case PropType^.Kind of
tkInteger:
SetOrdProp(SomeComponent, PropInfo,
StrToInt(PropertyValue.Text));
tkChar:
SetOrdProp(SomeComponent, PropInfo, Ord(PropertyValue.Text[1]));
tkEnumeration:
SetOrdProp(SomeComponent, PropInfo, GetEnumValue(PropType,
PropertyValue.Text));
tkFloat:
SetFloatProp(SomeComponent, PropInfo,
StrToFloat(PropertyValue.Text));
tkString:
SetStrProp(SomeComponent, PropInfo, PropertyValue.Text);
end;
end;

Вы также можете установить значения свойств Set, Class и Method, но это будет немного сложнее. Немного позже я объясню как это можно сделать.

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

Это прекрасный способ, но он имеет потенциал для массового злоупотребления. Необходимо понимание других путей достижения этой цели и выбор соответствующей техники при создании своих проектов в Delphi. [001188]


Как правильно создавать органы управления в runtime?

Nomadic советует:

Примерно таким образом (Описываем метод-обработчик события OnClick формы):

{ Example }

procedure TForm1.OnClick(ASender: TObject);
var
btnTemp: TButton;
begin
{ Creating }
btnTemp := TButton.Create(Self);

{ You can use 'with btnTemp do' operator below }
{ Inserting to Form }
 btnTemp.Parent := Self;

{ Initialization }
btnTemp.Caption := 'I''m glad to see You';
btnTemp.SetBounds(20, 20, 80, 20);

{ You must define this event handler named 'OnBtnTempClick' }
btnTemp.OnClick := OnBtnTempClick;

{ Ready to show }
btnTemp.Visible := true;

{ Done. }
end;

[001189]


Как создать клон (копию, достаточно близкую к оригиналу) произвольного компонента?

Nomadic советует:

{
Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на
входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.
}
 function CreateClone(Src: TComponent): TComponent;
var
F: TStream;
begin
F := nil;
try
F := TMemoryStream.Create;
F.WriteComponent(Src);
RegisterClass(TComponentClass(Src.ClassType));
F.Position := 0;
Result := F.ReadComponent(nil);
finally
F.Free;
end;
end;

[001224]


Как заставить произвольный компонент реагировать на изменения в TDataSource?

Nomadic советует:

TFieldDataLink. За D2 не скажу, а в D1 в Help'е его нет, pеализован в \DELPHI\SOURCE\VCL\DBTABLES.PAS.

type
TMyForm = class(TForm)
{...}
Table1: TTable;
DataSource1: TDataSource;
private
FDL : TFieldDataLink;
procedure RecChange(Sender: TObject);
public
{...}
end;

procedure TMyForm.FormCreate(Sender: TObject);
begin
FDL:=TFieldDataLink.Create;
FDL.OnDataChange := RecChange;
FDL.DataSource := DataSource1;
FDL.FieldName := 'MyFieldName';
end;

procedure TTabEditDlg.FormDestroy(Sender: TObject);
begin
FDL.Free;
end;

procedure TTabEditDlg.MasterChange(Sender: TObject);
begin
{... тут pеагиpуй на изменения ...}
end;

За отслеживание различных событий, происходящих с TDataSource, в иерархии VCL отвечает класс TDataLink. TFieldDataLink - наследник, который выполняет маскирование событий, не относящихся к конкретному столбцу набора данных.

Если надо отслеживать изменения в любом столбце набора, используйте TDataLink. Если необходимо отслеживать события для некоторого подмножества строк набора данных, посмотрите на реализацию TGridDataLink. [001338]


Delphi 1

Доступ к другим компонентам из базового

Список-свойство Components[] существует во всех потомках TComponent и используется для хранения ссылок на все собственные компоненты. При вызове "mycomponent := TSomeComponent.Create(aComponent)", ссылка на mycomponent помещается в список aComponent Components[]. В большинстве случаев, в методе Create в качестве владельца компонентов определена форма, и ссылки на компоненты помещаются в список Components[] самой формы.

Метод FindComponent() (упомянутый где-то еще) только производит поиск компонентов в текущем списке Components[]. Если объект, который вы хотите найти, принадлежит другому компоненту, вы должны просканировать его список компонентов.

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

Хорошей альтернативой может служить способ, при котором вы всегда определяете базовый компонент в качестве владельца всех других ваших "подкомпонентов" (при их создании). После этого будет работать поиск по свойству вашего базового компонента Components[]. [001453]


Delphi 1

CANVAS.TEXTWIDTH

Установить размер шрифта для панели можно следующим образом:

With StatusBar1.Panels[1] do begin
Text := Edit1.Text;
Canvas.Font.Size := StatusBar1.Font.Size;
Width := Canvas.TextWidth(Text) + 10;
end;

[001463]


Delphi 1

Создание компонента

...чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:

TBoolList = class(TPersistent)
private
FValue1: Boolean;
FValue2: Boolean
published
property Value1: Boolean read FValue1 write FValue1;
property Value2: Boolean read FValue2 write FValue2;
end;

Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам =необходимо= перекрыть конструктор.

TMyPanel = class(TCustomPanel)
private
FBoolList: TBoolList;
public
constructor Create( AOwner: TComponent ); override;
published
property BoolList: TBoolList read FBoolList write FBoolLisr;
end;

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

constructor TMyPanel.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
FBoolList := TBoolList.Create;
end;

[001485]


Delphi 1

Циклический опрос компонентов

procedure TForm1.FormCreate(Sender: TObject);
var
I : integer;
begin
for I:= 0 to ComponentCount -1 do
if (Components[I] IS TEdit) then
(Components[I] AS TEdit).{Вашпараметр} := {ваше значение};
end;

Если вам необходимо идентифицировать конкретный набор edit-компонентов, поместите их на панели и сделайте примерно так:

procedure TForm1.FormCreate(Sender: TObject);
var
I : integer;
begin
with MyPanel do
for I:= 0 to ControlCount -1 do
if (Controls[I] IS TEdit) then
(Controls[I] AS TEdit).{Вашпараметр} := {Ваше значение};
end;

В контексте примера, Edit1, Edit2 и т.д. есть то же самое, что и Edit[1], Edit[2]. Если вы хотите иметь доступ к серии элементов управления как к элементам массива, поместите их в TList.

MyArr := TList.Create;
MyArr.Add(Edit1);
MyArr.Add(Edit2);
...

For i := 0 To MyArr.count - 1 Do
(MyArr.items[i] As TEdit).Enabled := False;

MyArr.Free;

procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
for I := 0 to ComponentCount -1 do
if Components[I] is TEdit then
TEdit(Components[I]).Whatever := 10;
end;

Для получения доступа используйте:

TButton(mylist.items[i]).property := sumpin;

или

TButton(mylist.items[i]).method;

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

Procedure TMyForm.MyButtonHandler(Sender: TObject);
Begin
Case (Sender As TComponent).Tag Of
1 : { что-то делаем }
2 : { делаем что-то еще }
.
.
End;
End;

Просто укажите в событии OnClick на MyButtonHandler для тех кнопок, в которых вы хотите использовать общий обработчик события. [001497]


Двумя словами

Мне надо добавить много строк в TListbox или в TCombobox или в TMemo или в TRichEdit, при этом сам объект постоянно мигает, перерисовываясь. Как избавиться от этого?

Nomadic скупо отвечает:

A: BeginUpdate/EndUpdate. [001522]


Delphi 1

Как мне создать компонент типа TField?

Наверное вы хотели создать класс, а не компонент? Класс является программируемым устройством, а не частью формы. Если вы поместили класс в модуль (скажем, myclass.pas) и вставили в вашу прогамму строку "uses myclass;", то воспользоваться им можно следующим образом:

type
aninstance: tMyclass;
begin
new (aninstance);
{эквивалент aninstance := tMyclass.create; }
...
{ здесь используем aninstance }
...
dispose (aninstance);
{ эквивалент aninstance.free; }
end;

[001525]


Delphi 1

Инкрементация строкового поля

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

Попробуйте это:

var
s : string;
begin
s := RevField.text;
s[1] := chr(ord(s[1]) + 1);
RevField.text := s;
end;

Здесь кроются 2 проблемы:

  1. Для увеличения значения вам необходимо извлекать символы из строки.

  2. Хотя вы можете получить доступ к отдельным символам через выделение подстроки, данный метод не срабатывает у некоторых свойств, таких как, например, свойство TStringField Text.

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

    function IncrementTrailingVersionLetter(Str: string): string;
    begin
    Str[Length(Str)] := Char(Ord(Str[Length(Str)]) + 1);
    IncrementTrailingVersionLetter := Str;
    end;

    и использовать ее следующим образом:

    with RevField do
    Text := IncrementTrailingVersionLetter(Text);

[001542]


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

Как правильно создавать компоненты в run-time? Что задавать в качестве параметра Owner при создании компоненты? Как обрабатывать события от созданных компонент, типа нажатий на кнопки?

Nomadic повествует:

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

Для того, чтобы созданный компонент появился на экране, надо указать его родителя, заполнив свойство Parent, например, NewButton.Parent := Form1;

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

type
TForm1 = class(TForm)
{ ... }
private
{ эта процедура будет вызываться при нажатии на кнопку }
procedure ButtonClicked(Sender : TObject);

public
{ в этой процедуре происходит создание кнопки }
procedure CreateButton;

end;

{ ... }

procedure TForm1.CreateButton;
var
btn : TButton;
begin
btn := TButton.Create(Self);  { Уничтожать кнопку будет форма }
btn.Parent := Self;           { Родителем кнопки будет форма }
btn.OnClick := ButtonClicked; { Процедура, которая будет исполняться при }
btn.Visible := true;          { нажатии на кнопку }
end;

[001559]


Delphi 1

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

Если вы создаете в среде Delphi новый элемент управления, и вам нужно контролировать или ограничить свойства Left, Top, Width и Height, то спешу вас обрадовать: есть одно простое решение сделать это. Тем не менее, в документации по Delphi я не увидел ни малейшего намека на данный способ (включая CWG).

Ключевой момент кроется в изменении Left, Top, Width, Height и каждого BoundsRect в Delphi методом SetBounds() (доступного в TControl и во всех его потомках). SetBounds() - виртуальная фунция, делающее установление позиции и размера элемента управления делом легким и приятным. Тем не менее, о чем умалчивается в документации, что TControl.SetBounds() вызывает методы TControl SetLeft(), SetTop(), SetWidth() и SetHeight() при каждом изменении значений свойств Left, Top, Width, Height и BoundsRect.

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

В следующем примере мы имеем управление, которое автоматически изменяет свои пользовательские свойства X & Y, с той целью, чтобы они ссылались на центр элемента управления при изменении значений Left, Top, Width, Height или BoundsRect. И наоборот, Left и Top будут изменяться всякий раз при изменении свойств X & Y:

type
TMyControl = class(TControl)
private
FX, FY : integer;
{методы доступа к свойствам}
procedure SetX(value : integer);
procedure SetY(value : integer);
...
public
procedure SetBounds(aLeft, aTop, aWidth, aHeight : integer); override;
...
property X : integer read FX write SetX;
property Y : integer read FY write SetY;
end;
...

procedure TMyControl.SetX(value : integer);
begin
if FX <> value then
SetBounds(value - Width div 2, Top, Width, Height);
end;

procedure TMyControl.SetY(value : integer);
begin
if FY <> value then
SetBounds(Left, value - Height div 2, Width, Height);
end;

procedure TMyControl.SetBounds(aLeft, aTop, aWidth, aHeight : integer);
begin
{Продолжаем, и позволяем SetBounds() сделать свое дело...}
inherited SetBounds(aLeft, aTop, aWidth, aHeight);
{Теперь "регулируем" FX и FY согласно нашим новым границам.}
FX := Width div 2;
FY := Height div 2;
end;

Также в документации не упоминается о том факте, что частные поля FLeft, FTop, FWidth и FHeight, которые TControl использует для хранения внутренних значений, используются в методах SetLeft(), SetTop() и пр. для сравнения с текущими границами прямоугольника, при совпадении которых он не обновляется. Фактически, эти переменные нигде, кроме как в методе TControl SetBounds(), не корректируются (как в случае с FX и FY в приведенном выше примере).

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

В следующем примере мы имеем управление, которое ограничивает свою ширину и высоту в 100 пикселей:

type
TMyControl = class(TControl)
...
public
procedure SetBounds(aLeft, aTop, aWidth, aHeight : integer); override;
...
end;

...
procedure TMyControl.SetBounds(aLeft, aTop, aWidth, aHeight : integer);
begin
if aWidth > 100 then
aWidth  := 100;
if aHeight > 100 then
aHeight := 100;
inherited SetBounds(aLeft, aTop, aWidth, aHeight);
end;

[001594]


Использование холста в собственных компонентах

Вот мой совет по использованию холста в компонентах собственного приготовления:

TScrollingPaintBox = class(TScrollingWinControl)
private
FCanvas: TCanvas;
public
constructor Create(aOwner:TComponent); override;
destructor Destroy; override;
property Canvas: TCanvas read FCanvas;
end;

constructor TScrollingPaintBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
end;

destructor TScrollingPaintBox.Destroy;
begin
FCanvas.Free;
inherited Destroy;
end;

TControlCanvas важен, поскольку он создает DC, который принадлежит HWND элементу управления. Также, важно перекрытие вашего конструктора и деструктора, чтобы убедиться в том, что они действительно вызываются. [001634]


Delphi 1

Управление именами переменных

Вот образец кода, который я создал для тестирования динамически создаваемых компонентов; я надеюсь, что помог вам...:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
arr : array [1..30] of TBitBtn;
procedure BitButtonClick(Sender: TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.BitButtonClick(Sender: TObject);
begin
if TBitBtn(Sender).Font.Style = [] then
begin
TBitBtn(Sender).Font.Style := [fsBold];
TBitBtn(Sender).Font.Color := clRed;
end
else
begin
TBitBtn(Sender).Font.Style := [];
TBitBtn(Sender).Font.Color := clBlack;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
x, y,
f : integer;
begin
x := 20;
y := 20;
for f := 1 to 30 do
begin
arr [f] := TBitBtn.Create (Form1);
if arr [f] <> nil then
begin
arr [f].Parent := Form1;
arr [f].left := x;
arr [f].top := y;
arr [f].width := 35;
arr [f].Height := 25;
arr [f].caption := IntToStr (f);
arr [f].tag := f;
arr [f].OnClick := BitButtonClick;
inc (x, arr [f].width + 20);
if (x + arr [f].width) > form1.width then
begin
x := 20;
inc (y, arr [f].height + 20);
end;
end;
end;
end;

end.

Я подразумеваю, что существует два способа:
  1. Воспользуйтесь FindComponent. Будем использовать имена компонентов:

    var
    lab: TLabel;
    begin
    lab := TLabel(FindComponent('Label1'));
    lab.Caption := 'Эй!'
    end;

  2. Воспользуйтесь свойством Tag. Установите у каждой метки свойство Tag (например, с 1 пo 100), и воспользуйтесь следующим кодом:

    procedure TForm1.Button2Click(Sender: TObject);
    var
    i: smallint;
    begin
    for i := 0 to ComponentCount-1 do
    if (Components[i] is TLabel) AND (Components[i].Tag = 3) then
    begin
    TLabel(Components[i]).Caption := 'Это третий!';
    break;
    end;
    end;

Как насчет цикла, в котором вы пройдетесь по всем вашим компонентам (надеюсь, Вы знакомы со свойством вашей формы Components)? Это можно сделать приблизительно так:

var
I: Integer;
begin
for I := 0 to ComponentCount -1 do
if Components[I] is TLabel then
TLabel(Components[I]).Caption := 'Это он!';
end;

Поместите метки в TList. Затем вы можете сделать приблизительно так:

TLabel(mylist.items[MyValue]).Caption := 'Это оно!';

function LabelCaption(MyValue: Integer; Text: string) : Boolean;

function LabelCaption(MyValue: Integer; Text: string) : Boolean;
var
LabelCount,
Loop: Integer;
begin
Result := False;
LabelCount := 0;
for Loop := 0 to ComponentCount - 1 do
begin
if Components[Loop] is TLabel then  { это метка ? }
begin
INC(LabelCount);
if LabelCount = MyValue then  { соответствует индекс моему значению ? }
begin
Component[Loop].Caption := Text;
Result := True;
end;
end;
end;
end;

Вызвать это можно следующим образом:

if LabelCaption(10, 'Это я!') then
WriteLn('Мы нашли это!');

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

Поиск можно выполнять следующим образом:

MyLabels[MyLabels.IndexOf(Label10)].Caption := 'Еще один!';

[001636]


Письмо читателя

Компонента HTML - редактора

Nomadic советует:

Если у тебя стоит MS Internet Explorer 5, то считай, редактор у тебя в кармане ;-) Дело в том, что вместе с эксплорером идет DHTML -- ActiveX контрол, представляющий собой редактор HTML-ок, покруче, чем FrontPage Express даже, т.к. держит даже стили (.css). Лежит в C:\Program Files\Common Files\Microsoft Shared\Triedit. В Дельфи устанавливается через меню Components|Import ActiveX Control. При распространении своей программы с этим компонентом не забудь, что помимо копирования на машину клиента всех файлов из приведенного выше каталога нужно, чтоб они зарегистрированы были (regsvr32 имяфайла). [001730]


Delphi 1

Максимальное количество компонентов в .DCR

...возможно, ваша проблема связана тем, что процесс использует свободное пространство на вашем жестком диске. Ошибка может возникнуть, если размер временных данных, сохраняемых на диске, превышает свободное пространство. Ошибка исчезает, если вы удаляете только один компонент? Вы на верном пути... [001795]


Письмо читателя

Как бы попроще перемещать компонент во время работы программы?

Своим опытом делится Олег Кулабухов:

Нижеприведенный пример показывает как перемещать компонент при перетаскивании его нажатой левой кнопкой мыши при нажатом Ctrl.

procedure TForm1.Button1MouseDown(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
{$IFNDEF WIN32}
var
pt : TPoint;
{$ENDIF}
begin
if ssCtrl in Shift then begin
ReleaseCapture;
SendMessage(Button1.Handle, WM_SYSCOMMAND, 61458, 0);
{$IFNDEF WIN32}
GetCursorPos(pt);
SendMessage(Button1.Handle,
WM_LBUTTONUP,
MK_CONTROL,
Longint(pt));
{$ENDIF}
end;
end;

[001812]


Delphi 1

fsStayOnTop ~не наверху~

Тема: fsStayOnTop ~не наверху~
От: Philip Kapusta 74170,3550

Почему, если присвоить свойству FormStyle значение fsStayOnTop, форма так и не остается на самом верху?

Просто добавьте application.RestoreTopMosts в обработчик события формы OnPaint. Это ошибка.

Могли бы вы рассказать об этом чуть-чуть поподробнее? Delphi где-то в неправильном месте осуществляет вызов NormalizeTopMosts?

Borland говорит что это Windows, но это случается когда StayonTop-форма НЕ является главной формой. (Некоторые английские программисты чтобы получить эту отговорку потратили несколько сотен долларов, звоня в американскую службу помощи по телефону 1-800).

- Fred S. [001002]


Без иконки в панели задач?

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

Application.CreateHandle;
ShowWindow(Application.Handle, SW_HIDE);
Application.ShowMainForm := FALSE;

Да, чуть не забыл, есть еще одна вещь. При нормальном поведении TApplication создает дескриптор и показывает окно прежде, чем далее начнет что-то "происходить". Чтобы избежать этого, вам необходимо создать модуль, содержащий единственную строчку в секции initialization:

IsLibrary := True;

... и поместить этот модуль ПЕРВЫМ в .DPR-файле в списке используемых модулей. Этим мы "одурачиваем" TApplication, и оно думает что оно запущено из DLL, тем самым изменяя свое обычное поведение.

- Neil J. Rubenking [001037]


Delphi 1

Передача переменных форме

...поможете мне создать функцию, с помощью которой я передам переменные в TFormClass? Проблема в том, что MyDlg.Execute() не захотела компилироваться, поскольку, как сообщил мне компилятор, я не могу использовать MyDlg (определенный как: TForm).

Эта функция может выглядеть примерно так:

function ExecuteDialog( FormClass: TFormClass; var Data ): Boolean;

Я могу вам дать еще один совет: сделать все ваши формы наследниками одного класса, в котором объявлены виртуальные методы SetData и GetData.

{ ----------------------- }
unit ExecFrms;
interface
uses Forms, Controls;
type
TExecForm = class( TForm )
public
procedure GetData( var Data ); virtual; abstract;
procedure SetData( var Data ); virtual; abstract;
end;
TExecFormClass = class of TExecForm;

function ExecuteDialog( FormClass: TExecFormClass;
var Data ): Boolean;

implementation

function ExecuteDialog( FormClass: TExecFormClass;
var Data ): Boolean;
begin
with FormClass.Create( Application ) do
try
SetData( Data );
Result := ShowModal = mrOK;
if Result then GetData( Data );
finally
Release;
end;
end;

end.
{ ----------------------- }

Как вы можете видеть, я поместил функцию ExecuteDialog в тот же самый модуль.

После того как Delphi создаст форму, вы должны в модуле формы сделать четыре вещи:

  1. вручную измените предка формы, с TForm на TExecForm;
  2. добавьте ExecFrms в список используемых модулей;
  3. добавьте тип записи для хранения данных, необходимых диалогу; и
  4. перекрыть методы SetData и GetData.
{ ----------------------- }
unit MyDlgs;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms,
Controls, Buttons, StdCtrls, Spin, ExtCtrls,
ExecFrms;

type
{ Запись для данных, необходимых модальной форме... }
TMyDlgData = record
FormCaption: string;
FormWidth: Integer;
end;

TMyDlg = class( TExecForm )
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
Bevel1: TBevel;
Edit1: TEdit;
SpinEdit1: TSpinEdit;
public
procedure SetData( var Data ); override;
procedure GetData( var Data ); override;
end;

var
MyDlg: TMyDlg;

implementation

{$R *.DFM}

procedure TMyDlg.SetData( var Data );
begin
with TMyDlgData( Data ) do
begin
Edit1.Text := FormCaption;
SpinEdit1.Value := FormWidth;
end;
end;

procedure TMyDlg.GetData( var Data );
begin
with TMyDlgData( Data ) do
begin
FormCaption := Edit1.Text;
FormWidth := SpinEdit1.Value;
end;
end;

end.
{ ----------------------- }

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

{ Добавьте ExecFrms и MyDlgs в список USES вызывающего модуля. }

procedure TForm1.GetNewCaptionAndWidthBtnClick( Sender: TObject );
var
Data: TMyDlgData;
begin
Data.FormCaption := Caption;
Data.FormWidth := Width;
if ExecuteDialog( TMyDlg, Data ) then
begin
Caption := Data.FormCaption;
Width := Data.FormWidth;
end;
end;

Не поверите: данный код работает еще со времён Turbo Vision!

- Ed Jordan [001052]


Delphi 1

Освобождение экземпляров формы

В нашем примере для решения задачи мы передаем конструктору переменную формы. Затем, при закрытии формы, мы сбрасываем эту переменную.

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

TMyForm = class(TForm)
...
private
FormVar: ^TMyForm;
public
constructor Create(AOwner: TComponent; var AFormVar: TMyForm);
destructor Destroy; override;
end;

constructor TMyForm.Create(AOwner: TComponent; var AFormVar: TMyForm);
begin
FormVar := @AFormVar;
inherited Create;
.....
end;

destructor TMyForm.Destroy;
begin
FormVar^ := nil;
inherited Destroy;
end;

MyForm := TMyForm.Create(Self, MyForm);
MyOtherForm := TMyForm.Create(Self, MyOtherForm);

Этот код при разрушении окна автоматически сбрасывает все, что вы передаете в AFormVar, в nil.

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

- Jeff Fisher [001053]


Delphi 2

Условие создания главной формы?

Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически "другую" форму НЕ нужно будет загружать.

Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения) выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает из друх форм главную:

begin
IF FALSE THEN
BEGIN
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
END;
Randomize;
IF Random < 0.5 THEN Application.CreateForm(TForm1, Form1)
ELSE Application.CreateForm(TForm2, Form2);
Application.Run;
end.

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

- Neil Rubenking [001057]


Динамическое создание и циклическое связывание форм

Тема: Динамическое создание и циклическое связывание форм

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

Необходимый для осуществления этого метод очень прост. В моем примере я использую 3 формы с именами Mainform, Form1 и Form2. На Mainform я установил кнопку, которая выводит Form1, из нее вы можете вызвать любое количество форм (перемещаться между ними) через соответствующие кнопки, расположенные на этих формах. В моем примере "переключение" происходит между формами Form1 и Form2.

Шаг 1. Разместите следующие две строчки в секции interface той формы, которая у вас будет главной:

const
mrNext = 100;
mrPrevious = 101;

Шаг 2. Разместите на главной форме кнопку и добавьте следующий код в обработчик события ее нажатия:

var
MyForm: TForm;
R, CurForm: Integer;
begin
R := 0;
CurForm := 1;
while R <> mrCancel do begin
Case CurForm of
1: MyForm := TForm1.Create(Application);
2: MyForm := TForm2.Create(Application);
end;
try
R := MyForm.ShowModal;
finally
MyForm.Free;
end;
case R of
MrNext : Inc(CurForm);
MrPrevious : Dec(CurForm);
end;
// эти 2 строчки позволят нам не выходить за границы
if CurForm < 1 then CurForm := 2
else if CurForm > 2 then CurForm := 1;
end; // while
end;

Шаг 3. Добавьте формы 1 и 2 (и любые другие, какие вы хотите иметь) в список используемых модулей формы MainForm.

Шаг 4. В форме Form1 и Form2 добавьте MainForm в список используемых модулей (чтобы они видели константы.)

Шаг 5. На форму Form1, Form2, и все последующие, добавьте 2 TBitBtn'а, с заголовками "Next" и "Previous". In the OnClick Events for these buttons add the following line of code.

Если это кнопка Next, добавьте: ModalResult := mrNext;
Если это кнопка Previous, добавьте: ModalResult := mrPrevious;

[001067]


Как заставить формы минимизироваться на панель задач с анимацией?

Nomadic советует:

Дело-то вот в чем: Главным окном программы дельфийской является не главная форма, а окно TApplication, которое имеет нулевые размеры, поэтому его не видно. Именно для него показывается иконка на панели задач. Когда пользователь нажимает кнопку минимизации на главной форме, команда минимизации передается этому окну, и сворачивается именно оно, а для остальных просто делается hide. А так как окно TApplication имеет нулевые размеры, то и анимации никакой не видно.

А чтобы этого избежать, необходимо:

В исходном тесте модуля проекта после вызова Application.Initialize выполнить вызов

// В исходном тесте модуля проекта после вызова Application.Initialize
SetWindowLong(Application.Handle, GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);

В исходном тексте модуля главной формы перекрыть следующие методы -

// // В классе формы
// Интерфейс
protected
procedure CreateParams(var p: TCreateParams); override;
procedure WMSysCommand(var m: TMessage); message WM_SYSCOMMAND;

// Реализация
procedure TMainForm.CreateParams(var p: TCreateParams);
begin
inherited;
p.WndParent := 0;
end;

procedure TMainForm.WMSysCommand(var m: TMessage);
begin
m.Result := DefWindowProc(Handle, m.Msg, m.wParam, m.lParam);
end;

Вместо SetWindowLong в MDI-приложениях лучше использовать

ShowWindow(Application.Handle, SW_HIDE);

[001070]


Перемещение формы не за заголовок III

Ситников Митрий советует:

В следующем примере показано как можно передвигать форму если пользователь "захватил" Client-пространство:

unit Main;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
MX: integer;
MY: integer;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Shift<>[ssLeft] then
begin
MX:=X;
MY:=Y;
end else
begin
Left:=Left+X-MX;
Top:=Top+Y-MY;
end;
end;

end.

[001076]


Перемещение формы не за заголовок IV

Как мне переместить форму, не имеющую заголовка?

Выберите элемент управления (или саму форму) и напишите это в его (ее) обработчике события OnMouseDown (данный пример дан только для формы):

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Perform ( WM_SYSCOMMAND, SC_MOVE+2, 0 );
end;

Классно! Намного проще метода NCHitTest, который я предлага. Хотя многое из того, чтобы вы мне написали, я не понял. Для чего нужно прибавлять 2 к параметру SC_MOVE? В справке по API об этом ничего не сказано.

Ну хорошо, есть недокументированный способ сообщить Windows о необходимости перемещения окна таким же способом, что и с помощью заголовка (это может вызвать неадекватную реакцию системы, не делайте этого!). Другим способом перемещения окна является перекрытие WMNCHITTEST и возвращения им значения HTCAPTION. Тем не менее, обычно я предпочитаю пользоваться методом SC_MOVE+2, поскольку он не требует создания потомков, а только создание обработчика OnMouseDown. Отчасти аналогично, вы можете добавлять константы SC_SIZE к WM_SYSCOMMAND для получения размера окна подобно тому, как если бы вы потянули его за бордюрчик. В основном мы добавляем код hittest - 9. В следующем классе определена панель, которая сама изменяет свои размеры при щелчке в ее нижнем правом углу, и сама перемещается, если вы щелкнули по ней где-то еще.

Type
TMovablePanel = Class ( TPanel )
Private
Procedure wmNCHitTest ( Var Message : TWMNCHitTest ); message WM_NCHITTEST;
Protected
Procedure MouseDown ( Button : TMouseButton; Shift : TShiftState; X, Y : Integer ); override;
End;

Procedure TMovablePanel.wmNCHitTest ( Var Message : TWMNCHitTest );
Begin
With Message, ScreenToClient ( Pos ) Do
If ( X < Width - 10 ) And
( Y < Height - 10 )
Then Message.Result := HTCAPTION
Else Message.Result := HTCLIENT;
End;

Procedure TMovablePanel.MouseDown ( Button : TMouseButton; Shift : TShiftState; X, Y : Integer );
Begin
If Button = mbLeft
Then Begin
ReleaseCapture;
Perform ( WM_SYSCOMMAND, SC_SIZE + HTBOTTOMRIGHT - 9, 0 );
End
Else Inherited MouseDown ( Button, SHift, X, Y );
End;

- Robert Wittig [001113]


Delphi 1

Перемещение формы не за заголовок V

Вот как это можно сделать...

{Определение в главной форме...}
TForm1 = class(TForm)
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;

{... и реализация обработчика события}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;                    { вызвали унаследованный обработчик сообщения, }
if  M.Result = htClient then  { щелкнув в клиентской области окна? }
M.Result := htCaption;      { если так, то мы заставили Windows думать, }
{ что щелчок был произведен по заголовку окна. }
end;

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

  1. Выключите все BorderIcons формы.
  2. Убедитесь в том, что заголовок является пустой строкой.
  3. BorderStyle = bsNone
  4. Перекройте процедуру формы CreateParams как показано ниже:

    type
    TForm1 = class(TForm)
    {       ...
    другие объявления
    ...}
    protected
    procedure CreateParams(var Params : TCreateParams); override;
    public
    end;

    {... другой код ...}

    implementation

    {...}

    procedure TForm1.CreateParams(var Params: TCreateParams);
    begin
    inherited CreateParams(Params);
    with Params do
    Style := Style or ws_Border or ws_ThickFrame;
    end;

    {...}
    end.

Var
Moving  : Boolean;
OldX, OldY : Integer;
...............
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
If Button = mbLeft Then    {нас интересует только левая кнопка}
Begin
OldLeft := X;           {Сохраняем текущую позицию}
OldTop := Y;
Moving := True;
End;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
{Если необходимо переместить окно относительно своей оригинальной позиции}
If Moving Then Self.SetBounds
(Self.Left + X - OldLeft, Self.Top + Y - OldTop, Self.Width,
Self.Height);

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
If Button = mbLeft Then
Moving := False;              {Останавливаем перемещение}
end;

Не забудьте назначить эти методы каждому элементу управления вашей формы, например так:

Self.Panel1.OnMouseDown := Self.OnMouseDown;

[001750]


Как работать с формой, куда динамически передаются страницы (PageControl) из форм-хранителей (с использованием наследования)?

Nomadic советует:

Кидаю проект-болванку, сделанную перед началом работы над основным -

unit Unit1; //базовая форма хранителя страницы
interface
uses ...
type
TBPgFrm = class(TForm)
Panel1: TPanel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
Label1: TLabel;
public
function PgInit: boolean; virtual;
function PgValid: boolean; virtual;
end;

implementation

{$R *.DFM}
function TBPgFrm.PgInit: boolean;
begin
result:= MessageDlg(Label1.Caption+': PgInit',
mtConfirmation, mbOkCancel, 0)=mrOK;
end;

function TBPgFrm.PgValid: boolean;
begin
result:= MessageDlg(Label1.Caption+': PgValid',
mtConfirmation, mbOkCancel, 0)=mrOK;
end;

end.

unit Unit2; //главная форма проекта; содержит первую страницу
interface //и кнопки Cancel, Prev & Next/Finish.
uses ...
type
TPagesDlg = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
Prev: TButton;
CancelBtn: TButton;
Next: TButton;
Label1: TLabel;
procedure CancelBtnClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure NextClick(Sender: TObject);
procedure PrevClick(Sender: TObject);
private
Frms: TList;
procedure AddForms;
end;

var PagesDlg: TPagesDlg;

implementation

uses Unit1, Unit3, Unit4, Unit5;

{$R *.DFM}
procedure TPagesDlg.AddForms; //размещение динамических страниц
var i: word;
begin
Frms:= TList.Create;
Frms.Add(TBPgFrm1.Create(Self));
Frms.Add(TBPgFrm2.Create(Self));
for i:= 0 to 1 do TBPgFrm(Frms[i]).TabSheet1.PageControl := PageControl1
end;

procedure TPagesDlg.CancelBtnClick(Sender: TObject);
begin Close; end;

procedure TPagesDlg.FormDestroy(Sender: TObject);
var i: word;
begin
for i:= Frms.Count-1 downto 0 do TBPgFrm(Frms[i]).Free;
Frms.Free;
end;

procedure TPagesDlg.NextClick(Sender: TObject);
var
i: word;
vi: Boolean;
begin
Next.Enabled:= false;
if PageControl1.PageCount=1 then AddForms;
i:= PageControl1.ActivePage.PageIndex;
if i=0 then vi:= true else vi:= TBPgFrm(Frms[i-1]).PgValid;
if vi then
with PageControl1 do
if i=PageCount-1 then
begin
CancelBtnClick(Sender); exit;
end
else
begin
ActivePage:= FindNextPage(ActivePage, True, false);
if ActivePage.PageIndex=PageCount-1 then Next.Caption:= 'Finish';
Prev.Enabled:= true;
if TBPgFrm(Frms[i]).PgInit then Next.Enabled:= true else PrevClick(Sender);
end
else
Next.Enabled:= true;
end;

procedure TPagesDlg.PrevClick(Sender: TObject);
begin
Prev.Enabled:= false;
with PageControl1 do
begin
ActivePage:= FindNextPage(ActivePage, false, false);
Prev.Enabled:= ActivePage.PageIndex>0;
end;
Next.Caption:= 'Next'; Next.Enabled:= true;
end;

end.

unit Unit3; //наследник с RadioGroup.
interface
uses ...
type
TBPgFrm3 = class(TBPgFrm)
RadioValid: TRadioGroup;
public
function PgValid: boolean; override;
end;

implementation

{$R *.DFM}

function TBPgFrm3.PgValid: boolean;
begin
result:= RadioValid.ItemIndex=0;
end;

end.

unit Unit4; // наследник с CheckBox.
interface
uses ...
type
TBPgFrm2 = class(TBPgFrm)
CheckValid: TCheckBox;
public
function PgValid: boolean; override;
end;

implementation
{$R *.DFM}

function TBPgFrm2.PgValid: boolean;
begin
result:= CheckValid.Checked;
end;

end.

В Delphi 4 появились новые возможности, в частности, возможность докинга визуальных компонент, в частности, форм, на различные DockSite, в том числе и на TPageControl. Это более удобно. Кроме того, Вы имеете возможность использования TFormLoader из библиотеки VG Library. [001090]


IMHO файл *.dfm - это компилированный ресурс с определением установок формы. А можно ли как-то увидеть этот ресуpс в исходном виде?

Nomadic советует:

  1. File|Open... ТвояФорма.DFM - увидишь текст;

  2. "\delphi\bin\convert ТвояФорма.DFM" - получится ТвояФорма.TXT (можно и наоборот).

Идею в массы: в DN/VC/NC можно настроить viewer'ом .DFM .BAT'ник, который скажет convert;wpview;del - и заглядывать в .DFM не открывая Delphi.

Кстати, функции, которые реализуют это преобразование, доступны для использования в личных целях :)

CLASSES.PAS:

[...]
{ Object conversion routines }

procedure ObjectBinaryToText(Input, Output: TStream);
procedure ObjectTextToBinary(Input, Output: TStream);

procedure ObjectResourceToText(Input, Output: TStream);
procedure ObjectTextToResource(Input, Output: TStream);

[001092]


Определение перемещения формы I

Кто-нибудь знает как мне определить перемещение пользователем главной формы приложения (не изменение ее размеров), кроме как использования таймера и проверки значений свойств Form.Top и Form.Left?

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

  1. WM_WINDOWPOSCHANGING (возникает перед перемещением),
  2. WM_WINDOWPOSCHANGED (возникает после перемещения), или
  3. WM_MOVE (возникает после перемещения)
- Robert Wittig [001105]


Delphi 2

Определение перемещения формы II

...это сообщение windows, оно посылается при перемещении формы. Вы должны объявить процедуру в секции protected класса формы.

Procedure WMMove(Var Message : TWMMove); message WM_Move;

Procedure TForm1.WMMove(Var Message : TWMMove);
begin
Label1.Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message.
YPos);
end;

Событие генерируется в течение всего времени перемещения. Поэтому вам необходимо проверять, удерживается ли на мыши нажатой левая кнопка. [001751]


Можно ли сделать так - одновременно иметь на экране всегда доступную форму - например, "Hавигатор", и, открывая модальные формы, иметь всегда доступ к форме "Hавигатор"?

Nomadic советует:

Обманом можно все.

procedure ShowAlmostModal(FormModal:TForm);
begin
NavigatorForm.Enabled:=false;
FormModal.ShowModal
end;

И вот это пpивесь на OnShow почти модальной фоpмы

procedure FormShow(Sender:Tobject);
begin
NavigatorForm.Enabled:=true;
end;

[001110]


Как создать окна непрямоугольной формы и работать с ними?

Nomadic советует:

Достаточно создать регион нужной формы и вызвать SetWindowRgn -

HRGN rgn := CreateEllipticRgn( 10,10,100,100 );
SetWindowRgn( hMyWnd,rgn ); // Вот и будет круглое окно

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

Попpобуйте вот этот обpаботчик OnCreate : Hа меня это пpоизвело впечатление.

procedure TForm1.FormCreate(Sender: TObject);
const W=36*pi/180;
var R,R1,R2: HRgn; X,Y,i:integer;

function S(a:integer;R:integer):integer;
begin
Result:=round(R*sin(W*a));
end;

function C(a:integer;R:integer):integer;
begin
Result:=round(R*cos(W*a));
end;

function GetStarReg(X,Y,R:integer):HRGN;
var P : array [0..4] of TPoint;
begin
P[0] := Point(X, Y-R);
P[1] := Point(X-S(4,R), Y-C(4,R));
P[2] := Point(X-S(8,R), Y-C(8,R));
P[3] := Point(X-S(2,R), Y-C(2,R));
P[4] := Point(X-S(6,R), Y-C(6,R));
Result := CreatePolygonRgn(P, 5, WINDING);
end;

begin
X:=Width div 2;
Y:=Height div 2;
R:=GetStarReg(X,Y,100);
i:=1;
repeat
R1:=GetStarReg(X-S(i,120),Y-C(i,110),40);
CombineRgn(R,R,R1,RGN_OR);
inc(i,2);
until i>9;
R1:=GetStarReg(X,Y,30);
CombineRgn(R,R,R1,RGN_DIFF);

R1:=CreateEllipticRgn(3,3,Width-6,Height-6);
R2:=CreateEllipticRgn(20,10,Width-20,Height-10);
CombineRgn(R1,R1,R2,RGN_DIFF);
CombineRgn(R,R,R1,RGN_OR);

SetWindowRgn(Handle, R, True);
end;

[001116]


Как запретить кнопку Close [x] в заголовке окна?

Nomadic советует:

Вот кусок, который делает все, что тебе нужно:

procedure TForm1.FormCreate(Sender: TObject);
var
Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then
begin
MessageBeep(0);
Key := 0;
end;
end;

{ Disable close button }
procedure TForm1.Button1Click(Sender: TObject);
var
SysMenu: HMenu;
begin
SysMenu := GetSystemMenu(Handle, False);
Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
end;

{ Enable close button }
 procedure TForm1.Button2Click(Sender: TObject);
begin
GetSystemMenu(Handle, True);
Perform(WM_NCPAINT, Handle, 0);
end;

Но это окно можно закрыть из TaskBar'а. [001131]


Мерцание формы

Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет?

Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других "барабашек". В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.

procedure BeginScreenUpdate( hwnd : THandle );
begin
if (hwnd = 0) then
hwnd := Application.MainForm.Handle;
SendMessage( hwnd, WM_SETREDRAW, 0, 0 );
end;

procedure EndScreenUpdate( hwnd : THandle; erase : Boolean );
begin
if (hwnd = 0) then
hwnd := Application.MainForm.Handle;
SendMessage( hwnd, WM_SETREDRAW, 1, 0 );
RedrawWindow( hwnd, nil, 0, DW_FRAME + RDW_INVALIDATE +
RDW_ALLCHILDREN + RDW_NOINTERNALPAINT );
if (erase) then
Windows.InvalidateRect( hwnd, nil, True );
end;

- Jeff Johnson [001132]


Минимизация модального окна

Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановить pаботу в моей фоpме до обpаботки этого модального окна. Hо пpи этом я теpяю возможность убpать (минимизиpовать) мою фоpму

Nomadic советует:

function TMyForm.Execute: TModalResult;
begin
Show;
try
SendMessage(Handle, CM_ACTIVATE, 0, 0);
ModalResult := 0;
repeat
Application.HandleMessage;
if Application.Terminated then ModalResult := mrCancel;
if ModalResult = mrCancel then CloseModal;
until ModalResult <> 0;
Hide;
Result := ModalResult;
SendMessage(Handle, CM_DEACTIVATE, 0, 0);
finally
Hide;
end;
end;

Конечно, в TMyForm должно быть FormStyle := fsStayOnTop; [001148]


Прозрачная форма

Dmitry V. Koreyba советует:

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

var   FullRgn, ClientRgn, CtlRgn : THandle;

procedure TForm1.DoInvisible;
var
AControl : TControl;
A, Margin, X, Y, CtlX, CtlY : Integer;
begin
Margin := ( Width - ClientWidth ) div 2;
FullRgn := CreateRectRgn(0, 0, Width, Height);
X := Margin;
Y := Height - ClientHeight - Margin;
ClientRgn := CreateRectRgn( X, Y, X + ClientWidth, Y + ClientHeight );
CombineRgn( FullRgn, FullRgn, ClientRgn, RGN_DIFF );

for A := 0 to ControlCount - 1 do begin
AControl := Controls[A];
if ( AControl is TWinControl ) or ( AControl is TGraphicControl )
then with AControl do begin
if Visible then begin
CtlX := X + Left;
CtlY := Y + Top;
CtlRgn := CreateRectRgn( CtlX, CtlY, CtlX + Width, CtlY + Height );
CombineRgn( FullRgn, FullRgn, CtlRgn, RGN_OR );
end;
end;
end;
SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(ClientRgn);
DeleteObject(FullRgn);
DeleteObject(CtlRgn);
end;

procedure TForm1.DoVisible;
begin
FullRgn := CreateRectRgn(0, 0, Width, Height);
CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
DoInvisible;

end;

[001150]


Каким образом можно изменить системное меню формы?

Nomadic советует:

Hе знаю как насчет акселераторов,надо поискать, а вот добавить пункт меню(Item) - пожалуйста

type
TMyForm=class(TForm)
procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;
end;

const
ID_ABOUT = WM_USER+1;
ID_CALENDAR=WM_USER+2;
ID_EDIT = WM_USER+3;
ID_ANALIS = WM_USER+4;

implementation

procedure TMyForm.wmSysCommand;
begin
case Message.wParam of
ID_CALENDAR:DatBitBtnClick(Self) ;
ID_EDIT :EditBitBtnClick(Self);
ID_ANALIS:AnalisButtonClick(Self);
end;
inherited;
end;

procedure TMyForm.FormCreate(Sender: TObject);
var
SysMenu:THandle;
begin
SysMenu:=GetSystemMenu(Handle,False);
InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit');
end;

[001156]


Как сделать MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов?

Nomadic советует:

Ваpиант 1. CoolBar.

procedure TMainForm.SetBands(AControls: array of TWinControl;ABreaks: array of boolean);
var
i: integer;
begin
with CoolBar do
begin
for i:=0 to High(AControls) do
begin
if Bands.Count=succ(i) then TCoolBand.Create(Bands);
with Bands[succ(i)] do
begin
if Assigned(Control) then Control.Hide;
MinHeight:=AControls[i].Height;
Break:=ABreaks[i];
Control:=AControls[i];
Control.Show;
Visible:=true;
end
end;

for i:=High(AControls)+2 to pred(Bands.Count) do Bands[i].Free
end
end;

и

procedure TMsgForm.FormActivate(Sender: TObject);
begin
MainForm.SetBands([ToolBar],[false])
end;

Пpимечание:
Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:

AutoSize:=false; try ... finally AutoSize:=true;

Ваpиант 2.

TMainForm
...
object SpeedBar: TPanel
...
Align = alTop
BevelOuter = bvNone
object ToolBar: TPanel
...
Align = alLeft
BevelOuter = bvNone
end
object RxSplitter1: TRxSplitter
...
ControlFirst = ToolBar
ControlSecond = ChildBar
Align = alLeft
BevelOuter = bvLowered
end
object ChildBar: TPanel
...
Align = alClient
BevelOuter = bvNone
end
end
 TMdiChild {пpародитель всех остальных}
..
object pnToolBar: TPanel
...
Align = alTop
BevelOuter = bvNone
Visible = False
end
end;

procedure TMDIForm.FormActivate(Sender: TObject);
begin
pnToolBar.Parent:=MainForm.ChildBar;
pnToolBar.Visible:=True;
end;

procedure TMDIForm.FormDeactivate(Sender: TObject);
begin
pnToolBar.Visible:=false;
pnToolBar.Parent:=self
{pnToolBar.Visible:=false}
end;

[001179]


Заполнение изображением MDI-формы IV

Nomadic советует:

Я делал так:

type
.... =class(TForm)
....
procedure FormCreate(Sender:TObject);
procedure FormDestroy(Sender:TObject);
....
private
FHBrush:HBRUSH;
FCover:TBitmap;
FNewClientInstance:TFarProc;
FOldClientInstance:TFarProc;
procedure NewClientWndProc(var Message:TMessage);
....
protected
....
procedure CreateWnd;override;
....
end;

.....

implementation

{$R myRes.res} //pесуpс с битмапом фона

procedure .FormCreate(...);
var
LogBrush:TLogbrush;
begin
FCover:=TBitmap.Create;
FCover.LoadFromResourceName(hinstance,'BMPCOVER');
With LogBrush do
begin
lbStyle:=BS_PATTERN;
lbHatch:=FCover.Handle;
end;
FHBrush:=CreateBrushIndirect(Logbrush);
end;

procedure .FormDestroy(...);
begin
DeleteObject(FHBrush);
FCover.Free;
end;

procedure .CreateWnd;
begin
inherited CreateWnd;
if (ClientHandle <> 0) then
begin
if NewStyleControls then
SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or
GetWindowLong(ClientHandle, GWL_EXSTYLE));

FNewClientInstance:=MakeObjectInstance(NewClientWndProc);
FOldClientInstance:=pointer(GetWindowLong(ClientHandle,GWL_WNDPROC));
SetWindowLong(ClientHandle,GWL_WNDPROC,longint(FNewClientInstance));
end;
end;

procedure .NewClientWndProc(var Message:TMessage);

procedure Default;
begin
with Message do
Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg, wParam,
lParam);
end;

begin
with Message do
begin
case Msg of
WM_ERASEBKGND:
begin
FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush);
Result := 1;
end;
else
Default;
end;
end;
end;

[001228]


Предотвращение закрытия формы

Igor Nikolaev aKa The Sprite советует:

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

procedure TForm1.FormCreate(Sender: TObject);
var hMenuHandle:HMENU; begin
hMenuHandle := GetSystemMenu(Handle, FALSE);
IF (hMenuHandle <> 0) THEN
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;

[001399]


Немедленный TrayIcon после старта приложения

Нужно чтобы при запуске приложения сразу исчезала с экрана главная форма и появлялась TrayIcon. В Ваших "Советы по Дельфи" на данный вопрос я нашел два решения (раздел Классы/TForm) к сожалению ни одно решения на моем компьютере не работало :-(. В связи с этим было решено продолжить поиск, и решение было найдено:

На Главную форму приложения помещаем компонент (TEdit или другой любой, который может иметь фокус), затем устанавливаем свойства:

Visible:=True;
TabOrder:=0;

В обработчик события OnEnter записываем (этот код взял из "Советов по Дельфи"):

Application.Minimize;
ShowWindow(Application.Handle, SW_HIDE);
Button1.SetFocus;                                     //Устанавливаем фокус на другой компонент формы (у меня был Button1 )
 Edit1.Visible:=False;                                 //Делаем добавочный компонент невидимым - т.к. он больше нам не нужен

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

Для восстановления формы необходим код:

ShowWindow(Application.Handle, SW_RESTORE);
Application.Restore;

Для реализации TrayIcon был использован компонент TRxTrayIcon из библиотеки RxLib ver.2.75 Данное решение имеет один недостаток - незначительное мерцание формы при ее сворачивании.

-----------------------------------------------------------------
С уважением Пащенко Андрей Владимирович (Bibigon)
г.Архангельск, 2000. [001420]


Заполнение формы изображением

Почитал я тут ваши 'Советы ......' и решил дополнить ответ по теме создание фона на форме раздела классы\tform

Чтобы заполнить вашу форму повторяющимся изображением нужно

  1. Разместить на форме image
  2. Присвоить его свойству visible значение false
  3. В обработчике события формы OnCreate разместить следующий код :
form1.brush.bitmap:=image1.picture.bitmap;

Хочу заметить , что при использовании этого св-ва св-ва color & style не действительны !А самое главное при изменении размеров формы ваше повторяюшееся изображение будет автоматически перересовываться и вам не понадобится обрабатывать событие paint & resize .

С уважением, Dmitry Morsin [001422]


Создание консольных приложений

Создание консольных приложений. (Об этом в советах немножко есть, но очень не конкретно)

Как уже отмечалось в совете [000092] (да и в Хелпе) в консольных приложениях в Delphi можно использовать в принципе весь дельфийский арсенал. Правда и работать они будут лишь под Windows. (Кстати этот способ можно применить для модернизации программ на Паскале под Windows).

Этот код был использован для вывода результатов работы программы проверки (неважно чего) чтобы не приходилось смотреть файл с результатами. Главная проблема была в том, что консоль (если запуск был из Windows) оставалась висеть позади формы до её закрытия. Вреда конечно никакого, но не приятно. Если же запуск из Нортона или т.п., то всё идёт нормально.

Program MyProgram;

{$APPTYPE CONSOLE}

uses
Windows, Forms, Dialogs, SysUtils, StdCtrls, Controls; // и (или) т.п.

...

var
...
SH,SW: integer;
MainForm: TForm; // если нужна форма
Memo: TMemo;
// могут быть также любые другие визуальные компоненты
...

// здесь могут быть процедуры и функции, т.е всё как в обычном Паскале

Begin

... // здесь какой-то код

{ а здесь, перед выводом формы, есть два пути:}
{ так}
FreeConsole; // Отцепиться от консоли, т.е она просто исчезнет (в случае запуска из Windows) и останется только форма
{ или так}
//  Handle:= GetForegroundWindow; // Получить Handle консоли
//  ShowWindow(Handle, SW_HIDE);  // Спрятать консоль
// а в конце, перед завершением
//  ShowWindow(Handle, SW_SHOW); // Показать консоль

{ для помещения формы в центр экрана}
SH:= Screen.Height;
SW:= Screen.Width;

MainForm:= TForm.Create(nil);
with MainForm do
try
BorderStyle:= bsSizeable;
Height:= 390;
Width:= 390;
Left:= (SW - Width) div 2;
Top:= (SH - Height) div 2;
Caption:= 'Моя программа';
// здесь могут быть и другие компоненты
Memo:= TMemo.Create(MainForm);
with Memo do begin
Parent:= MainForm;
Align:= alClient;
BorderStyle:= bsNone;
Font.Name:= 'Courier New Cyr';
Font.Size:= 9;
ScrollBars:= ssVertical;
Lines.LoadFromFile('MyProgram.txt');
end;
ShowModal;
finally
Free;
end;

{ или можно вывести сообщение, например в случае неудачи (или наоборот)}
with CreateMessageDialog('Текст сообщения',mtInformation,[mbOk]) do
try
Caption := 'Заголовок';
ShowModal;
finally
Free;
end;

...

//  это для второго пути, иначе она так и останется висеть свёрнутой
//  ShowWindow(Handle, SW_SHOW); // Показать консоль

 End.

С уважением, Михаил Чумак. [001427]


Delphi 1

События приложения

...проблема в том, что когда приложение Delphi минимизировано, десктиптор окна в этом случае совершенно другой. Объект Application в действительности дескриптор собственного окна! Application.Handle является окном, которое активно при минимизированном приложении. Когда вы минимизируете ваше приложение, все формы просто прячутся (hidden). Обратите внимание на методы Application Minimize и Restore. Также обратите внимание, что у TApplication есть два недокументированных события, OnMinimize и OnRestore. Они принадлежат приложению, поскольку в TForm нет обработчиков событий, возникающих при минимизации главного окна. Немного странно. Я думаю так сделано для поддержки SDI-приложений. [001459]


Нужны ли мне формы в сервере приложений?

Nomadic отвечает:

Да.

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

Application.ShowMainForm := False

в файле проекта.

Пример:

begin
Application.ShowMainForm := False;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

[001467]


Создание формы на основе строки

Обзор

В данном документе рассказывается о том, как в Delрhi можно создать экземпляр формы на основе строки, содержащей имя типа. Код примера прилагается.

На кого расчитан данный документ?

На любого программиста, имеющего начальные знания для работы с Delphi. Имеет отношение к любой версии Delphi.

Создание формы на основе строки

Чтобы можно было создать экземпляр формы на основе строки, содержащей имя типа, вы должны в первую очередь зарегистрировать данный тип в Delphi. Это выполняется функцией "RegisterClass". RegisterClass описан следующим образом:

procedure RegisterClass(AClass: TPersistentClass);

AClass - класс TPersistent. Другими словами, класс, который вы хотите регистрировать, в какой-то точке должен наследоваться от TPersistent. Поскольку все элементы управления Delphi, включая формы, соблюдают это требование, то проблем быть не должно. Но такой способ не пройдет, если регистрируемые классы наследуются непосредственно от TObject.

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

procedure TForm1.Button2Click(Sender: TObject);
var
b : TForm;
f : TFormClass;
begin
f := TFormClass(findClass('Tform2'));
b := f.create(self);
b.show;
end;

Данный код создаст тип TForm2, который мы зарегистрировали с помощью RegisterClass.

Демонстрационный проект

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

В первой форме разместите поле редактирования и кнопку. Удалите все формы, кроме главной, из списка AutoCreate. Наконец, скопируйте приведенный ниже код в unit1, он позволит вам создавать форму по имени типа класса, введенному в поле редактирования.

unit Unit1;

interface

uses
Unit2, Unit3, Unit4, Unit5, Windows, Messages,
SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

 {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterClass(Tform2);
RegisterClass(Tform3);
RegisterClass(Tform4);
RegisterClass(Tform5);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
f : Tformclass;
begin
f := tformclass(findClass(edit1.text));
with f.create(self) do
show;
end;

[001493]


Показ логотипа при запуске приложения III

Своим опытом делится Nomadic:

A: Смотрите пример в X:\DELPHI\DEMOS\DB\MASTAPP\mastapp.dpr.

Удобно использовать функцию ShowSplashWindow из rxLib. [001508]


Показ логотипа при запуске приложения IV

Как добавить логотип к вашему приложению

Логотип (заставка) является важной составляющей вашего приложения. Он позволяет занять время во время загрузки и сообщить пользователю дополнительные сведения о программе. Логотип сделает ваше приложение более профессиональным.

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

Имеется множество типов заставок (Splash Screen). Самый распространный тип - показ логотипа во время загрузки приложения. Обычно такие экраны отображают имя приложения, автора, версию, авторские права и изображение или иконку, идентифицирующую приложение.

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

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

  1. Добавьте форму в ваш проект --> File | New Form.. Комментарий: Заставка (Splash Screen) похожа на любую другую форму.
  2. Измените свойство формы Name на SplashScreen
  3. Измените свойство формы BorderStyle на bsNone
  4. Измените свойство формы Position на poScreenCenter
  5. Сделайте заставку привлекательной и функциональной путем добавления на нее необходимых компонентов и изображений. (компоненты Label, Panel, Image, Shape и Bevel)
  6. Отредактируйте свойства добавленных компонентов
  7. Выберите в меню Delphi IDE Options | Project
  8. Уберите SplashScreen-форму из списка Auto-create-списка (списка автоматически создаваемых форм)

    Комментарий: Вы динамически создаете экземпляр заставки

  9. Добавьте модуль, содержащий TSplashScreen, в список используемых модулей главной формы вашего приложения. Пример:

    unit Unit1;
    interface
    uses SysUtils, WinTypes, WinProcs, Messages, Classes,
    Graphics, Controls, Forms, Dialogs, StdCtrls,
    unit2;  <---- поместите сюда

    Комментарий: В нашем примере TSplashScreen объявлен в Unit2

  10. Выберите в меню Delphi IDE View | Project Source
  11. Вставьте между ключевым словом begin и перед любым Application.Create() следующий код:

    SplashScreen := TSplashScreen.Create(Application);
    SplashScreen.Show;
    SplashScreen.Refresh;

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

    SplashScreen.Free;

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

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

    Добавьте следующий код на этапе #11:

    for x:= 1 to 10000000 do
    begin
    x:=x;
    end;

    {PROJECT1.DPR}

    program Project1;

    uses
    Forms,
    Unit1 in 'UNIT1.PAS' {Form1},
    Unit2 in 'UNIT2.PAS' {SplashScreen};

    {$R *.RES}
    var
    x: longint;
    begin
    SplashScreen:= TSplashScreen.Create(Application);
    SplashScreen.Show;
    SplashScreen.Refresh;;
    for x:= 1 to 10000000 do
    begin
    x:=x;
    x:=x;
    end;
    Application.CreateForm(TForm1, Form1);
    Application.Run;
    end.

    {UNIT1.PAS}

    unit Unit1;

    interface

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

    type
    TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

    var
    Form1: TForm1;

    implementation

    {$R *.DFM}

    procedure TForm1.FormShow(Sender: TObject);
    begin
    splashscreen.free;
    end;

    end.

    {UNIT2.PAS}

    unit Unit2;

    interface

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

    type
    TSplashScreen = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Shape1: TShape;
    Shape2: TShape;
    Shape3: TShape;
    private
    { Private declarations }
    public
    { Public declarations }
    end;

    var
    SplashScreen: TSplashScreen;

    implementation

    {$R *.DFM}

    end.

[001527]


Как правильно закрыть и удалить форму? Почему моя MDI Child форма при закрывании просто минимизируется?

Своим опытом делится Nomadic:

A: Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть. [001520]


Как установить максимальный и минимальный размер формы

Если вы хотите контролировать изменение пользователем размера вашей формы, воспользуйтесь установкой значения MinMax. (Если для этих целей вы используете метод resize, это работает, но выглядит не так хорошо.)

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

unit MinMax;

interface

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

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMGetMinMaxInfo(var MSG: Tmessage); message WM_GetMinMaxInfo;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var MSG: Tmessage);
Begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do
begin
with ptMinTrackSize do
begin
X := 300;
Y := 150;
end;
with ptMaxTrackSize do
begin
X := 350;
Y := 250;
end;
end;
end;

end.

[001535]


Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?

Своим опытом делится Nomadic:

Стиль окна-формы указывается в CreateParams (если не перепутал). Только вот когда перемещаешь его, фон остается со старым куском экрана. Чтобы этого не происходило, то когда pисуешь своё окно, запоминай, что было под ним,а пpи пеpемещении восстанавливай.

HDC hDC = GetDC(GetDesktopWindow()) тебе поможет.. [001591]


Как сделать невидимой главную форму?

Своим опытом делится Nomadic:

Hаписать Application.ShowMainForm:=false в файле пpоекта. [001644]


Модальные формы с нормальной минимизацией

Своим опытом делится Nomadic:

А если на главной форме в событии Application.OnMinimize запоминать последнюю активную форму(LastActiveForm = Screen.ActiveForm), а в событии Application.OnRestore выдавать ShowWindow(LastActiveForm.Handle,SW_NORNAL), то она и восстановится, как тположено :-) [001656]


Как минимизиpовать все запущеные окна?

Своим опытом делится Nomadic:

/* Hачало (MINIMIZE.DPR)
{$APPTYPE CONSOLE}
program Minimize;
uses Windows,Messages;
var Count:integer;

function EnumProc (WinHandle: HWnd; Param: LongInt): Boolean; stdcall;
begin
if (GetParent (WinHandle) = 0) and (not IsIconic (WinHandle)) and
(IsWindowVisible (WinHandle)) then begin
PostMessage (WinHandle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
Inc(Count);
end;
EnumProc := TRUE;
end;

begin
Count:=0;
EnumWindows (@EnumProc, 0);
Writeln('Minimized:',Count,' windows');
end. конец (MINIMIZE.DPR)*/

[001665]


Delphi 2

Добавление к форме BorderIcons

В свое время я делал это на C, и я не уверен в том, что я знаю, как сделать это на Delphi, тем не менее:

В Windows v3.1x, вам необходимо будет перекрыть сообщение WM_NCPAINT, использовать для определения размера кнопок и пр. функцию GetSystemMetrics, затем, после вызова унаследованного WM_NCPAINT, отрисовывать вашу кнопку. Вам также необходимо будет перекрыть WM_NCMOUSEDOWN и пр., для того, чтобы вы могли обрабатывать "сообщения щелчка". Таким образом можно рисовать и TButton и TSpeedButton, но это будет немного труднее.

Для получения идентификатора системного меню необходимо вызвать GetSystemMenu(). После этого, для добавления собственных пунктов меню, используется AddMenuItem. Вероятно, для работы с элементами меню и пр., вам понадобится перекрывать WndProc... Все-же, сделать это с помощью Delphi намного проще. [001723]


Delphi 1

Вызов функций из различных дочерних MDI окон

Попробуйте так:

var
MyMDIForm: TForm;

begin

MyMDIForm:=ActiveMDIChild;
MyMDIForm.DefaultSize;

end;

Сам я это не пробовал, но вам советую... :-)

Попробуйте воспользоваться ссылкой на ActiveMDIChild:

TChild(ActiveMDIChild).SomeMethod;

[001725]


Delphi 1

Закрытие модальной формы

...я думаю проблема еще в том, что обработчик FormActivate вызывается как часть кода, выполняющегося при перемещении фокуса на новую форму, поэтому Delphi подавляет изменения фокуса во время работы данного обработчика. Если вы когда-нибудь пробовали трассировать изменения фокуса с помощью Windows API, то вы знаете, что изменение фокуса во време его смены приводит к его бесконечному зацикливанию в Windows!!!

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

Я испытывал это с простой программой: одна форма с кнопкой, которая активизурует диалог About, после чего он сам немедленно закрывается. Пример не очень полезен, но цель его - показать принцип.

Unit Form1;

.... (обычная чепуха ) ...
implementation

uses
About;

procedure TForm1.Button1Click(Sender: TObject);
begin
AboutBox.ShowModal;
end;

Unit About;

.... (обычная чепуха ) ...

implementation

uses
Messages;

procedure TAboutBox.FormActivate(Sender: TObject);
begin
PostMessage( Handle, WM_CLOSE, 0, 0 );
end;

Я надеюсь, это поможет. Если нет, извините.

Лучший способ: Поместите на модальной форме невидимую кнопку, установите ее собственность ModalResult на mrOK, и поместите следующий код в обработчик события OnActivate:

postmessage(Button1.Handle, wm_mousedown,0,0);
postmessage(button1.Handle, wm_mouseup,0,0);

Функция возвращает idOK, поэтому вы всегда можете узнать, была ли нажата кнопка Отмены. [001729]


Delphi 1

Управление максимизацией формы

...чтобы показать вам как это можно сделать, я создал небольшую программу, позволяющую управлять размером формы при ее максимизации. Она сделана таким образом, что позволяет исключить мигание, которое вы можете видеть при изменении ее размера в обработчике события OnResize. В основном, этот код работает с сообщением wm_getminmaxinfo, т.е. перехватывает и обрабатывает его. Для того, чтобы использовать данный стиль формы вместо стандартного стиля, принятого в Delphi, просто скомпилируйте следующий файл с паскалевским кодом в DCU-файл. Затем замените вашу стандартную TForm новой TMaxForm и добавьте (если вы назвали паскалевский файл maxform.pas) maxform в спискок используемых модулей. А теперь сам код описываемого модуля:

unit Maxform;

interface

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

type
TMaxForm = class(TForm)
private
{ Private declarations }
fmh, fmw, fml, fmt : word;
procedure mymax(var m: TWMGETMINMAXINFO);
message wm_getminmaxinfo;
published
property maxheight : word read mh write mh;
property maxwidth  : word read mw write mw;
property maxleft   : word read ml write ml;
property maxtop    : word read mt write mt;
constructor create(AOwner : TComponent); override;
end;

implementation

procedure TMaxForm.mymax(var m : TWMGETMINMAXINFO);
begin
m.minmaxinfo^.ptmaxsize.x := fmw;
m.minmaxinfo^.ptmaxsize.y := fmh;
m.minmaxinfo^.ptmaxposition.x := fml;
m.minmaxinfo^.ptmaxposition.y := fmt;
end;

constructor TMaxForm.create(Aowner : TComponent);
begin
fmw := screen.width;
fmh := screen.height;
fmt := 0;
fml := 0;
inherited create(aowner);
end;

end.

[001731]


Delphi 1

Создание формы с шириной < 102

Добавьте следующее определение в секции intarface вашей формы:

procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;

и следующий код в секцию implementaion:.

procedure TForm1.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
begin
with message do begin
MinMaxInfo^.ptMinTrackSize.x := 20;
end;
end;

Я не нашел способа сделать это в IDE, но во время выполнени приложения можно сделать так:

procedure TForm1.Form1OnCreate(Sender: TObject);
begin
Width := 50;
end;

[001734]


Delphi 1

Разрушение модальной формы при деактивации

procedure TForm1.AppDeactivate(Sender: TObject);
var
hw: HWnd;
CurTask: THandle;
WndStyle:Longint;
begin
CurTask:=GetWindowTask(handle);
hw:=GetWindow(GetDesktopWindow, GW_CHILD);
while GetWindowTask(hw)<>CurTask do
hw:=GetWindow(hw, GW_HWNDNEXT);while (hw<>handle) and (GetWindowTask(hw)=CurTask) do
begin
PostMessage(hw, WM_Close, 0, 0);
hw:=GetWindow(hw, GW_HWNDNEXT);
end;
end;

[001736]


Письмо читателя

Ограничение размеров окна

Своим опытом делится Nomadic:

procedure TFMain.WMGetMinMaxInfo(var Msg: TMessage);
BEGIN
with TWMGetMinMaxInfo(Msg).MinMaxInfo^ do
begin
ptMaxTrackSize := Point(800, 600); // макс. размеры окна
ptMinTrackSize:= Point(400, 200);  //минимальные
ptMaxPosition:= Point(50, 55);     //позиция при развёртывании
ptMaxSize:= Point(750, 550);       //размер при развёртывании
end;
Msg.Result := 1;
END;

Описание обработчика:

procedure WMGetMinMaxInfo(var Msg:TMessage); message WM_GETMINMAXINFO;

[001737]


Delphi 1

Получение различных диалогов из шаблона формы

Попробуйте следующий код:

Application.CreateForm(TFormX, FormX);
FormX.ShowModal;
FormX.Free;

не забывайте о том, что свойство visible такой формы при ее создании должно быть установлено в false, в противном случае при попытке показать ее модально, вы получите ошибку. [001742]


Delphi 1

Отключение ALT+F4

Обратите внимание на событие формы closequery - если вы возвратите false (только если вы сами установите false), то форму можно закрыть только ВАШЕЙ командой close ---- в этом случае при попытке закрытия формы вы могли бы успеть произвести необходимые действия. [001746]


Delphi 1

Форма не существует? Так создайте!

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

frmNewForm := TNewForm.Create( owner );

Приведем 3 возможных решения вашей проблемы:

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

    IF frmNewForm = NIL THEN
    frmNewForm := TNewForm.Create( owner );
    frmNewForm.Show;

    с привлечением глобальных переменных

  2. Найдите ссылку на frmNewForm, которая сохраняется в списке компонентов родителя при вызове TForm.Create( owner ). В большинстве случаев это будет собственностью массива компонентов главной формы.

  3. Если у вас нет главной формы, котоую вы могли бы использовать в качестве родителя подформы, тогда воспользуйтесь методом TAppllication CreateForm( TForm, refernce ). Позже, когда вам понадобиться получить ссылку на подформу, вам нужно будет пройтись в цикле по свойству-массиву components вашего объекта application. Найдите форму по ее имени и получите ссылку.
Одно важное замечание: при разрушении объекта вы сами должны устанавливать указатель на объект в nil. В противном случае, в следующий раз вы можете получить GPF.

frmNewForm.Release;
frmNewForm := nil;

Если в качестве родителя формы вы определяете 'Application', то для ее поиска (чтобы убедиться, что она еще существует) необходимо перебрать все компоненты объекта Application.

Чтобы сделать это, вы можете выбрать один из двух способов:

Application.CreateForm(TSubForm, SubForm);

или

SubForm := TSubForm.Create(Application);

Затем вы можете проверить существование вашей формы, перебирая в цикле компоненты:

for i := 0 to Application.ComponentCount-1 do begin
if Application.Components[i] = SubForm then ... {форма существует};

Примечания:

  1. Если при создании формы вместо 'Application' вы используете 'Self', форма не будет являться компонентом Application, поэтому в дальнейшем вы не сможете ее найти, перебирая в цикле компоненты объекта Application.

  2. Вместо создания цикла, перебирающего все компоненты Application.Components, вы могли бы воспользоваться 'Application.FindComponent', но только в том случае, *если* после создания формы вы назначили ей имя (например, SubForm.Name := 'SubForm';). 'FindComponent' ищет компоненты в массиве Components по их *имени*, но форму таким образом можно найти только после того, как вы назначите ей имя.

  3. Используя для проверки существования формы что-то типа 'if SubForm = nil' учтите, что это может не сработать, если вы не установили ссылку на форму в nil при ее освобождении. Delphi не делает это автоматически.
[001748]


Delphi 1

Максимальная ширина формы

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

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

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

procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message
wm_GetMinMaxInfo;

а вот реализация:

procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
Msg.MinMaxInfo^.ptMinTrackSize.x := 130;
end;

Имейте в виду, что минимальная ширина окна в Windows 95 отличается от аналогичного значения в Windows 3.1. Поскольку Win95 добавляет новые кнопки в область заголовка окна (в случае, если вы определили их использование, например, кнопки Minimize или Maximize), то минимальная ширина немного больше, чем в Windows 3.1. Также следует принять во внимание разные размеры шрифта заголовка. [001752]


Delphi 1

FORM.TFORM.CREATE(???)

Не используйте (2)! Вы получите или GPF, или второй экземпляр NameOnForm, при этом потеряв указатель на первый.

Вот мое понимание того, как должны отличаться (1) и (3): Для showModal, (1) и (3) эквивалентны. Для show, (1) должен хранить nameOnForm открытым до закрытия приложения (или пока пользователь не закроет NameOnForm), в случае (3) nameOnForm закрывается при закрытии mainForm. [001754]


Delphi 1

Масштабирование окна III

Я полагаю, что описание в документации функции "PixelsPerInch" неверно, поскольку, исходя из моего опыта, она имеет отношение к размеру в пикселях/дюймах системных ШРИФТОВ, а не формы.

Например, Delphi свойство PixelsPerInch по умолчанию обычно содержит значение 96 для всех создаваемых вами форм, НЕЗАВИСИМО ОТ ЭКРАННОГО РАЗРЕШЕНИЯ ВАШЕЙ СИСТЕМЫ. В моей системе именно так, независимо от того, при каком разрешении я работаю: 640x480, 800x600, 1024x768 или др.

Тем не менее, при изменении вашего разрешения экрана, если вы устанавливаете "Large Fonts" (большие шрифты) вместо "Small Fonts" (маленькие шрифты), Delphi PixelPerInch по умолчанию для любых создаваемых вами форм теперь будет равен 120, и снова будет независеть от разрешения вашей системы.

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

Пример:

  • Вы создали форму, используя "Small Fonts". Вы найдете значение по-умолчанию PixelsPerInch, равное 96.

  • Ваш пользователь пытается запустить приложение в системе, где установлены "Large Fonts". Эта установка означает, что весь текст формы должен быть большим относительно остальной части формы из-за большого размера шрифта. Свойство PixelsPerInch для данного пользователя должно быть 120.
Если свойство вашей формы "Scaled" установлено в False, Delphi не предпримет никаких мер для компенсации изменения разрешения экрана. Ваш текст при этом, вероятно, будет большим, чем в то время, когда вы разрабатывали форму, и не вместится целиком в отведенное для него место.

Тем не менее, если свойство вашей формы "Scaled" установлено в True, Delphi автоматически смаштабирует форму с коэффициентом 120/96. При данном способе форма "вырастает" в соответствии с увеличенным размером шрифтов. После чего форма выглядит точто так, как вы ее разработали.

ПРИМЕЧАНИЕ: Масштабирование происходит только в случае, если пользовательское свойство PixelsPerInch отличается от его значения во время разработки. Насколько я знаю, это может случиться при смене размера шрифтов во время смены разрешения экрана.

В моем случае формы НИКОГДА не масштабировались сами, независимо от текущего разрешения экрана: 800x600, 1024x768 и пр., поскольку я всегда использовал "Small Fonts". Это в действительности уводило меня от этой проблемы. Моим решением было масштабирование формы вручную, используя ScaleBy(...).

Я полагаю что другим решением могло бы быть изменение свойства формы PixelsPerInch во время выполнения программы, когда форма только "готовится создаться". Эта хитрость позволила бы Delphi думать, что форма была разработана с использованием другого значения PixelsPerInch, поэтому ее необходимо соответственно смасштабировать. Например, изменение свойства формы PixelsPerInch с 96 на 80 во время ее создания заставить Delphi ее смасштабировать с коэффициентом 96/80. [001755]


Delphi 1

Освобождение формы

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

Попробуйте следующий код:

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);
private
{ Private declarations }
public
Form2: TForm;
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
if Form2 <> nil then
begin
Form2.Release;
Form2:= nil;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if Form2 = nil then
begin
Form2 := TForm.Create(Application);
Form2.Show;
end;
end;

end.

[Francisco Torres, ftorres@cenpes.petrobras.gov.br]

В вашей ситуации вы должны отказаться от такого кода:

begin
Application.Create(myForm);
Application.Run;
end.

И воспользоваться следующим:

begin myForm := TmyForm.Create(Application);
{ вставьте сюда нужный вам код }
myForm.Show; { ... или myForm.ShowModal }
{ вставьте сюда нужный вам код }
myForm.Hide; { ... если вы хотите скрыть ее }
{ вставьте сюда нужный вам код }
myForm.Free;
end.

Вы можете использовать методы формы "Create" и "Free" когда угодно и сколько угодно раз.

Не забывайте освобождать все формы перед завершением вашего приложения! [001756]


Delphi 1

Получение имени формы

Если вы используете свойство ClassName...

with Sender as TForm do
Label1.Caption := copy(ClassName,2,length(ClassName)-1);

Это даст желаемый эффект без дополнительного кодирования в методе формы OnCreate.

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

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

If Sender is TForm then
Label1.Caption := (Sender as TForm).Name ;

Выполнить этот код можно так:

Label1.Caption := Form1.Name ;

Но здесь появляется масса других проблем. Мне писали гневные письма о том, что свойство у Form не доступно во время выполнения приложения, что, вероятнее всего связано с тем, что класс формы еще не был проинициализирован. Если бы читали документацию по Delphi более тщательно, вы бы обратили внимание на тот момент, что установка свойства в Инспекторе Объектов (Object Inspector) НЕ означает его автоматическую установку во время выполнения программы. В ответ на ЭТУ ситуацию вам нужно будет установить это свойство явно (в нашем случае .Name) в методе формы .Create. Следующий пример БУДЕТ работать:

procedure TForm1.Create( Sender : TObject ) ;
begin
Form1.Name := 'Form1' ;
end ;

procedure TForm1.Button1Click( Sender : TObject ) ;
begin
Label1.Caption := Form1.Name ;
end ;

var
TC: TComponent;
begin
TC := label1.Owner;
label1.Caption := TC.ClassName;
end;

К своей форме я добавил кнопку, и в обработчике события поместил следующую строчку:

name := 'AName';

Затем, после щелчка на кнопке, я мог бы щелкнуть на форме, и заголовок метки изменился бы на 'AName'. Мое решение основывается на определении свойства Name в обработчике события создания формы. Т.е., если бы вы хотели назвать форму MyForm, то в обработчике события OnCreate вы должны написать следующее:

name := 'MyForm';

Я надеюсь, это поможет вам решить проблему. [001757]


Delphi 1

Скрытие окна заголовка формы

{ Чтобы код работал, включите Winprocs & WinTypes в список используемых модулей }

Procedure TYourFormName.HideTitlebar;
Var
Save : LongInt;
Begin
If BorderStyle=bsNone then Exit;
Save:=GetWindowLong(Handle,gwl_Style);
If (Save and ws_Caption)=ws_Caption then Begin
Case BorderStyle of
bsSingle,
bsSizeable : SetWindowLong(Handle,gwl_Style,Save and
(Not(ws_Caption)) or ws_border);
bsDialog : SetWindowLong(Handle,gwl_Style,Save and
(Not(ws_Caption)) or ds_modalframe or ws_dlgframe);
End;
Height:=Height-getSystemMetrics(sm_cyCaption);
Refresh;
End;
end;

Procedure TYourFormName.ShowTitlebar;
Var
Save : LongInt;
begin
If BorderStyle=bsNone then Exit;
Save:=GetWindowLong(Handle,gwl_Style);
If (Save and ws_Caption)<>ws_Caption then Begin
Case BorderStyle of
bsSingle,
bsSizeable : SetWindowLong(Handle,gwl_Style,Save or ws_Caption or
ws_border);
bsDialog : SetWindowLong(Handle,gwl_Style,Save or ws_Caption or
ds_modalframe or ws_dlgframe);
End;
Height:=Height+getSystemMetrics(sm_cyCaption);
Refresh;
End;
end;

[001759]


Delphi 1

Предотвращение изменения размера формы

Есть один способ сделать это: перехватить WM_NCHITTEST и возвратить нужные вам HTBOTTOM, HTBOTTOMLEFT, HTBOTTOM, HTTOP, HTOPLEFT и HTTOPRIGHT. Это заставит windows полностью игнорировать изменение размеров окна, если мышь тянет верхний или нижний контур окна. Фактически, windows даже не покажет специфический "резиновый" контур, демонстрирующий намерение изменить размеры окна. Для получения более подробной информации, обратитесь к описанию этого сообщения в справке по Windows API.

Вы можете перехватывать сообщение (смотри справку по ключевому слову Message) WM_GETMINMAXINFO. Оно "приходит" со структурой TMINMAXINFO. В этой структуре вы сами можете изменять значения полей, отвечающих за размер окна, таким образом запрещая пользователю изменять его размер.

Для получения более подробной информации, обратитесь к электронной документации.

[001761]


Delphi 1

Сколько открыто дочерних окон?

Пример (из электронной справки):

with Form1 do
for I := 0 to MDIChildCount-1 do
MDIChildren[I].Close;

так:

if (MDIChildCount=0) then ShowTheStatusPanel
else HideTheStatusPanel;

Создайте в главной форме процедуру с именем OnChildCountChange приблизительно такого вида:

if MDIChildCount = 0 then
Panel1.Show else Panel1.Hide;

и вызывайте ее в обработчиках событий ваших дочерних форм Destroy и Create:

MainForm.OnChildCountChange;

для обновления состояния компонента StatusBar. [001762]


Delphi 1

Размеры MDI-окна

Поместите следующую строку в секцию private класса, описывающего вашу форму:

procedure WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo); message
WM_GETMINMAXINFO;

... и следующую функцию в секцию implementation вашего модуля:

procedure YourClassNameHere.WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
begin
{
Следующий код не позволяет пользователю изменять размеры формы и позволяет заменить Width и Height требуемыми вами минимальными/максимальными значениями. (Во всяком случае, идея видна).
}
Message.MinMaxInfo^.ptMinTrackSize := Point(Width, Height);
Message.MinMaxInfo^.ptMaxTrackSize := Point(Width, Height);
end;

[001767]


Delphi 1

Открытие MDI-окон определенного размера

var
ProjectWindow: TWndProject;
begin
If ProjectActive=false then begin
LockWindowUpdate(ClientHandle);
ProjectWindow:=TWndProject.Create(self);
ProjectWindow.Left:=10;
ProjectWindow.Top:=10;
ProjectWindow.Width:=373;
ProjecTwindow.Height:=222;
ProjectWindow.Show;
LockWindowUpdate(0);
end;
end;

Используйте LockWindowUpdate перед созданием окна и после того, как создание будет завершено. [001771]


Письмо читателя

Как добавить свой пункт в системное меню программы?

Своим опытом делится Олег Кулабухов:

Нижеприведенный пример демонстрирует применение API-функции AppendMenu и последующий перехват WM_SYSCOMMAND именно с этой целью.

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const
SC_MyMenuItem = WM_USER + 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE),
MF_STRING,
SC_MyMenuItem,
'My Menu Item');
end;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Got the message') else
inherited;
end;

[001773]


Delphi 1

Позиционирование динамически создаваемой формы

Такой вот How-To я нашел в Интернете:

unit Runtime1;  { How-To 1.6 }

interface

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

type

TNewForm = class(TForm)
NewEdit: TEdit;
NewButton: TButton;
procedure NewButtonClick(Sender: TObject);
end;

TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ Обработчик OnClick для генерируемых форм }
 procedure TNewForm.NewButtonClick(Sender: TObject);
begin
NewEdit.Text := 'Привет!';
end;

{ Генерируем и показываем форму }
procedure TForm1.Button1Click(Sender: TObject);
var
NewForm: TNewForm;
begin
{ Создаем новую форму }
NewForm := TNewForm.CreateNew(Application);
{ Устанавливаем ее свойства }
with NewForm do
begin
Top := 140;
Left := 220;
Width := 435;
Height := 300;
Caption := 'Работает!';
{ Создаем новый Edit-компонент }
NewEdit := TEdit.Create(NewForm);
{ Устанавливаем его свойства }
with NewEdit do
begin
Parent := NewForm;
Left := 153;
Top := 40;
Width := 121;
Height := 29;
TabOrder := 1;
Text := 'Edit1';
end;
{ Создаем новый компонент-кнопку }
NewButton := TButton.Create(NewForm);
{ Устанавливаем его свойства }
with NewButton do
begin
Parent := NewForm;
Left := 153;
Top := 176;
Width := 121;
Height := 33;
TabOrder := 0;
Caption := 'Изменение Edit';
{ Делегируем компоненту обработчик OnClick }
OnClick := NewButtonClick;
end;
Show;
end;
end; end.

фактически, мы установили координаты, но не пытались передать новые значения. Кроме того, вы могли бы попробовать использовать свойство poScreenCenter, или вам что-то мешает?

Другой возможностью является хранение значений координат в Ini-файле, но, вероятно, уже думали над этим. [001774]


Delphi 1

Помещение формы в поток

Delphi имеет в своем распоряжении классную функцию, позволяющую сделать это:

procedure WriteComponentResFile(const FileName: string; Instance: TComponent);

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

function ReadComponentResFile(const FileName: string; Instance: TComponent):
TComponent;

[001778]


Delphi 1

Работа без форм

Да, с помощью диалогового окна Project Manager можно удалить форму из списка автоматически создаваемых при старте нового проекта.

В добавок к этому (чтобы получить .exe разумных размеров), вы можете удалить из исходного кода проекта строчки "Application.Run" и "uses Forms".

Разумеется, затем вам необходимо будет добавить некоторую функциональность в исходный код проекта (или сделайте это в одном или нескольких отдельных модулях и вызывайте эти процедуры непосредственно их исходного файла проекта). [001780]


Delphi 1

Выбор дочерних MDI-окон с помощью набора закладок TabSet

По всей видимости, дочерние MDI-окна не отвечают на те же сообщения Windows, которые обрабатываются другими окнами. Ниже приведен способ выбора определенного дочернего MDI-окна таким образом, чтобы оно стало активным. Я читаю значение из компонента TINIFile и активизирую определенное дочернее MDI-окно:

{
Делаем активным дочернее MDI-окно. Мы должны послать сообщение Windows API, поскольку дочернее MDI-окно может реагировать только на "аварийный" набор системных сообщений.
}
 ; i := ReadInteger( 'Main', 'ActiveMDIChild', -1 )
; IF (i>=0) AND (i<MDIChildCount)
THEN POSTMESSAGE( Self.Handle, WM_MDIACTIVATE,
MDIChildren[i].Handle, 0 )

MDI-формы обрабатываются другим обработчиком по-умолчанию (defMDIProc). Способов сделать это (см. заголовок) существует несколько. Дочерние Mdi-формы являются частью массива с именем (как ни странно) MDIChildren. Вы можете сделать так.....

For i := 0 To Form1.MDIChildCount - 1 Do
begin
If Form1.MDIChildren[i].Caption = 'Это первый!' Then
{Здесь можно активизировать дочернюю MDI-форму или выполнить какие-либо действия}
end;

MDIChildren[x] - указатель на экземпляр дочерней MDI-формы. Использование операторов IS и AS позволит вам иметь доступ к любым свойствам и методам любой дочерней формы.

  1. При открытии файла в набор Tabset добавляется новая закладка Tab, а ее заголовок ("caption") устанавливается равным имени открытого файла. Затем форма с помощью команды Tabset.AddObject добавляется как объект к tabset.

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

    TForm(TabsSet.Items.Objects[TabSet.TabIndex]).Show;

[001781]


Delphi 1

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

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

Это должно выглядеть приблизительно так:

in fMain.formCreate:
fLookup := tFLookup.create (self);
{отсюда был удален код показа (show)}

in fMain.btn1Click:
fEntry := tFentry.create (self);
fEntry.showModal;

in fMain.LookupButtonClick:
fLookup.showMODAL;

in fEntry.LookupButtonClick:
fLookup.showMODAL;

in fLookup.DoneButtonClick:
fLookup.Hide;

[001783]


Delphi 1

Изменение размера дочерних MDI-окон

Если вы хотите установить размер MDI-формы во время проектирования, просто задайте свойству Position значение poDefaultPosOnly, после чего она всегда будет иметь размер, который вы задали ей во время ее разработки. Если вы хотите позволить пользователю задавать размер по-умолчанию, то я предложил бы добавить соответствующий пункт в системное меню (для этого я использую сторонний компонент acMenus), с помощью которого пользователь может сохранить текущий размер в INI-файле (можно использовать две переменные, но я использую одну, в которой через запятую перечислены значения). После чего, в методе FormCreate, я читаю INI-файл и устанавливаю Height и Width соответственно. После того, как форма будет создана, в посылке сообщений необходимости нет. [001785]


Delphi 1

Прозрачный логотип

Получите DC экрана (Screen) и свяжите его с Canvas. Используйте Canvas как вы обычно пользуетесь canvas формы. Освободите DC. [001787]


Delphi 1

Альтернатива главной форме?

Ниже показан код, который проверяет параметр командной строки, в зависимости от значений которого главной становится та или иная форма:

var
bCondition: Boolean;

{$R *.RES}

begin

bCondition :=  ( ParamStr(1) = 'Form2'); {или другое условие, способное "переключать" главную форму }

if bCondition then begin {<<<}
Application.CreateForm(TForm1, Form1);
end {<<<} else
Application.CreateForm(TForm2, Form2);
Application.Run;

begin...end {<<<} необходим для того, чтобы вы могли воспользоваться Project Options Dialog.

Данный совет навеян книгой 'Delphi Programming Problem Solver' автора Neil Rubenking 1-56884-795-5. [001791]


Delphi 1

Различные размеры окна на различных платформах...

Следующие советы помогут вам держать правильный размер формы при других разрешениях:

a.) Установите свойство Autoscroll в 'FALSE'. Значение True не изменяет размеры формы во время выполнения приложения.

b.) Установите TrueType шрифт типа Arial, не оставляйте шрифт по-умолчанию 'SYSTEM''

c.) Установите Position на что-нибудь еще, кроме poDesigned, т.к. если вы пытались разместить форму в центре экрана при вашем разрешении 1280x780, то пользователь вряд ли ее увидит при разрешении 640x480.

d.) Поменяйте свойство шрифта Pitch с DEFAULT на VARIABLE

e.) Не меняйте свойство PixelsPerInch.

f.) Установите свойство Scaled в TRUE. Оно заставляет масштабировать форму в зависимости от значения свойства PixelsPerInch. [001813]


Опыт читателя

Можно ли рисовать на рамке окна?

Своим опытом делится Олег Кулабухов:

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

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
dc : hDc;
Pen : hPen;
OldPen : hPen;
OldBrush : hBrush;
begin
inherited;
dc := GetWindowDC(Handle);
msg.Result := 1;
Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc, Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width, Form1.Height);
SelectObject(dc, OldBrush);
SelectObject(dc, OldPen);
DeleteObject(Pen);
ReleaseDC(Handle, Canvas.Handle);
end;

[001819]


Опыт читателя

Как создать собственное hint-окно?

Своим опытом делится Олег Кулабухов:

procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false;
Panel1.Visible := false;
Panel1.BevelInner := bvNone;
Panel1.BevelOuter := bvNone;
Panel1.BorderStyle := bsSingle;
Panel1.Color := clWhite;
Button1.Hint := 'Hint test';
end;

procedure TForm1.ShowAHint(x : integer;
y : integer;
Caption : string;
Duration : LongInt);
var
dc : hdc;
OldFont : hFont;
pt : TSize;
p : pChar;
begin
if Timer1.Enabled <> false then
 Timer1.Enabled := false;
Timer1.Enabled := false;
if Panel1.Visible <> false then
Panel1.Visible := false;
if Caption = '' then exit;
Panel1.Caption := caption;
{Get the width of the caption string}
GetMem(p, Length(Panel1.Caption) + 1);
StrPCopy(p, Panel1.Caption);
dc := GetDc(Panel1.Handle);
OldFont := SelectObject(dc, Panel1.Font.Handle);
GetTextExtentPoint32(dc, p, Length(Panel1.Caption), pt);
SelectObject(dc, OldFont);
ReleaseDc(Panel1.Handle, Dc);
FreeMem(p, Length(Panel1.Caption) + 1);
{Position and show the panel}
Panel1.Left := x;
Panel1.Top := y;
Panel1.Width := pt.cx + 6;
Panel1.Height := pt.cy + 2;
Panel1.Visible := true;
{Fire off the timer to hide the panel}
Timer1.Interval := Duration;
Timer1.Enabled := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Panel1.Visible <> false then
Panel1.Visible := false;
Timer1.Enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{Let the button repaint}
Application.ProcessMessages;
ShowAHint(Button1.Left,
Button1.Top + Button1.Height + 6,
Button1.Hint,
2000);
end;

[001827]


Опыт читателя

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

Своим опытом делится Олег Кулабухов:

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form2 := TForm2.Create(Application);
Form2.Visible := FALSE;
ShowWindow(Form2.Handle, SW_SHOWNA);
end;

[001842]


Опыт читателя

Как запретить кнопки системного меню окна, `Закрыть`, `Открыть`?

Своим опытом делится Олег Кулабухов:

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

procedure TForm1.Button1Click(Sender: TObject);
begin
{Disable}
Form1.BorderIcons := Form1.BorderIcons -
[biSystemMenu, biMinimize, biMaximize];
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Enable}
Form1.BorderIcons := Form1.BorderIcons +
[biSystemMenu, biMinimize, biMaximize];
end;

[001846]


Опыт читателя

Можно ли реагировать на максимализацию/минимизацию окна до того, как это произойдет?

Своим опытом делится Олег Кулабухов:

Да, как обычно, перехватываем WM_SYSCOMMAND.

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) or
(Msg.CmdType = SC_MAXIMIZE) then
MessageBeep(0) else
inherited;
end;

[001859]


Проблемы ini-файла

Кто-нибудь имел какие-нибудь проблемы при использовании модуля TIniFile? Я думаю здесь какая-то детская проблема с кэшированием!!!

Вот что я делал:

(* c:\test.ini уже существует *)
myIni := TIniFile.Create('c:\test.ini');
With myIni do
begin
.... (добавляем новую секцию в test.ini
end;
myIni.Free;
RenameFile('c:\test.ini', 'c:\test1.ini');

Что я получил:

  1. test1.ini НЕ ИМЕЕТ добавленной мною секции;
  2. всякий раз при создании или открытии нового файла в том же самом каталоге с помощью File Manager, 'c:\test.ini' появляется вновь, и у него СУЩЕСТВУЕТ секция, которую я добавлял.

Я решил эту проблему добавлением следующей строки перед IniFile.Free:

WritePrivateProfileString(nil, nil, nil, PChar(IniFileName));

Для получения дополнительной информации обратитесь к электронной справке к разделу 'WritePrivateProfileString'.

- Tony Chang [001130]


Как создать Ini-файл в директории программы?

По умолчанию ini-файл создается в Windows-директории (например: TIniFile.Create('MFile.ini' )), что приводит к "захламлению" оной. Более (эко-)логично (за исключением случаев, когда программа делается для CD-ROM) если ini-файл создается в той же директории что и главная программа. Вот пример чтения и записи ini файла из директории программы:

function ReadIni(ASection, AString : String) : String;
var
sIniFile: TIniFile;
sPath : String[60];
begin
GetDir(0,sPath);
sIniFile := TIniFile.Create(sPath + '\Name.INI');
Result := sIniFile.ReadString(ASection, AString, S); sIniFile.Free;
end;

procedure WriteIni(ASection, AString, AValue : String);
var
sIniFile: TIniFile;
sPath : String[60];
begin
GetDir(0,sPath);
sIniFile := TIniFile.Create(sPath + '\Name.INI');
sIniFile.WriteString(ASection, AString, AValue);
sIniFile.Free;
end;

[001418]


Delphi 1

TMemoryStream

Думайте о потоке памяти как о расположенном в памяти файле. Команды для работы с потоком очень похожи на команды для работы с файлами. (В действительности, это ближе к команде blockwrite.)

Вот "медленный" путь записи строки в поток:

for i := 1 to Length(s) do memstream.Write(s[i], 1);

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

memstream.Write(s[1], Length(s));

Две строчки делают то же самое, они добавляют символы в поток. Если вы не делали никаких перемещений внутреннего курсора потока (seek), символы просто добавляются в конец.

Теперь, для соблюдения перевода каретки, вы должны добавлять эти спецсимволы сами:

memstream.Write(#13, 1);
memstream.Write(#10, 1);

Или вы можете использовать более изощренный метод:

procedure StreamWriteStr(var ms: TMemoryStream; s: string);
begin
ms.Write(s[1], Length(s));
end;

procedure StreamWriteLnStr(var ms: TMemoryStream; s: string);
begin
StreamWriteStr(ms, s + #13#10);
end;

Также, вы можете создать собственный класс-потомок TMemoryStream, с методом записи строк. [001717]


Дополненный TRegistry, умеет работать с значениями типа REG_MULTI_SZ (Windows NT, Windows 2000)

Кондратюк Виталий советует:

unit Reg;
{$R-,T-,H+,X+}

interface

uses Registry, Classes, Windows, Consts, SysUtils;

type

TReg = class(TRegistry)
public
procedure ReadStringList(const name : string; list : TStringList);
procedure WriteStringList(const name : string; list : TStringList);
end;

implementation

//*** TReg *********************************************************************
//------------------------------------------------------------------------------
// Запись TStringList ввиде значения типа REG_MULTI_SZ в реестр
//------------------------------------------------------------------------------
 procedure TReg.WriteStringList(const name : string; list : TStringList);
var
Buffer   : Pointer;
BufSize  : DWORD;
i, j, k  : Integer;
s        : string;
p        : PChar;
begin
{подготовим буфер к записи}
BufSize := 0;
for i:=0 to list.Count-1 do
inc(BufSize, Length(list[i])+1);
inc(BufSize);
GetMem(Buffer, BufSize);
k := 0;
p := Buffer;
for i:=0 to list.Count-1 do begin
s := list[i];
for j:=0 to Length(s)-1 do begin
p[k] := s[j+1];
inc(k);
end;
p[k] := chr(0);
inc(k);
end;
p[k] := chr(0);

{запись в реестр}
if RegSetValueEx(CurrentKey, PChar(name), 0, REG_MULTI_SZ, Buffer, BufSize) <> ERROR_SUCCESS then
raise ERegistryException.CreateResFmt(@SRegSetDataFailed, [name]);
end;
//------------------------------------------------------------------------------
// Чтение TStringList ввиде значения типа REG_MULTI_SZ из реестра
//------------------------------------------------------------------------------
 procedure TReg.ReadStringList(const name : string; list : TStringList);
var
BufSize,
DataType : DWORD;
Len, i   : Integer;
Buffer   : PChar;
s        : string;
begin
if list = nil then
Exit;
{чтение из реестра}
Len := GetDataSize(Name);
if Len < 1 then
Exit;
Buffer := AllocMem(Len);
if Buffer = nil then
Exit;
try
DataType := REG_NONE;
BufSize := Len;
if RegQueryValueEx(CurrentKey, PChar(name), nil, @DataType, PByte(Buffer), @BufSize) <> ERROR_SUCCESS then
raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [name]);
if DataType <> REG_MULTI_SZ then
raise ERegistryException.CreateResFmt(@SInvalidRegType, [name]);
{запись в TStringList}
list.Clear;
s := '';
for i:=0 to BufSize-2 do begin  // BufSize-2 т.к. последние два нулевых символа
if Buffer[i] = chr(0) then begin
list.Add(s);
s := '';
end
else
s := s + Buffer[i];
end;
finally
FreeMem(Buffer);
end;
end;

end.

[001195]


Как я могу определить доступные сервера приложений на этой машине через Registry?

Nomadic советует:

Прочитайте ключ под HKEY_CLASSES_ROOT\CLSID\*, просматривая его насчёт ключей, которые имеют подключ "Borland DataBroker". Эти вхождения и являются серверами приложений.

Ниже пример, который загружает имена доступных серверов приложений в Listbox:

uses Registry;
procedure TForm1.FormCreate(Sender: TObject);

var

I: integer;
TempList: TStringList;
begin
TempList := TStringList.Create;
try
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('CLSID', False) then
GetKeyNames(TempList);
CloseKey;
for I := 1 to TempList.Count - 1 do
if KeyExists('CLSID\' + TempList[I] + '\Borland DataBroker') then
begin
if OpenKey('CLSID\' + TempList[I] + '\ProgID', False)
then
begin
Listbox1.Items.Add(ReadString(''));
CloseKey;
end;
end;
finally
Free;
end;
finally
TempList.Free;
end;
end;

[001475]


Письмо от читателя

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

Nomadic советует:

Во-первых, можно по примеру Back Orifice воспользоваться функцией RegisterServiceProcess.

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

A: (EM, DS):

type
TForm1 = class(TForm)
Label1: TLabel;
RxTrayIcon1: TRxTrayIcon;
procedure FormCreate(Sender : TObject);
procedure RxTrayIcon1DblClick(Sender: TObject);
private
{ Private declarations }
procedure ApplicationMinimize(Sender : TObject);
procedure ApplicationRestore(Sender : TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMinimize := ApplicationMinimize;
Application.OnRestore := ApplicationRestore;
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.ApplicationRestore(Sender : TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.RxTrayIcon1DblClick(Sender: TObject);
begin
Application.Restore;
Application.BringToFront;
end;

(AK): Только сpазу предупреждаю про грабли, на которые я наступал -- будь готов к тому, что если пpи попытке закрытия приложения в OnCloseQuery или OnClose выводится вопрос о подтверждении, то могут быть проблемы с автоматическим завершением пpогpаммы пpи shutdown -- под Win95 просто зависает, под WinNT не завершается. Очевидно, что сообщение выводится, но его не видно (причем SW_RESTORE не сpабатывает). Решение -- ловить WM_QUERYENDSESSION и после всяких завеpшающих действий и вызова CallTerminateProcs выдавать Halt. [001563]


Delphi 1

Закрытие приложения при его деактивации

Попробуйте следующий код:

procedure TForm1.AppDeactivate(Sender: TObject);
begin
close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnDeactivate := AppDeactivate;
end;

[001727]


Delphi 1

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

Объект Delphi Application создает скрытое "application window" (окно приложения), и именно ему, а не главному окну приложения посылается команда "показать минимизированным". Чтобы обойти эту проблему, поместите следующую строчку в обработчик события OnCreate вашей главной формы:

ShowWindow(Handle, cmdShow);

[001763]


Delphi 1

Использование TstringList в визуальных компонентах

TStrings - абстрактный базовый класс, используемый многими визуальными компонентами, такими как, например, TListBox. Все, что вы хотите, имеется в TStringList, а если вам нужно следить только за объектами, то вместо него используйте TList. Для добавления элемента в конец списка используется метод Add. Для добавления элемента в определенное место списка используется метод Insert. Для получения строки из списка используется свойство Items. Обратите внимание на то, что счет начинается с нуля, поэтому последний элемент имеет порядковый номер Count-1 (Count это другое свойство). Для удаления строки используется метод Delete. Для нахождения строки в списке используется IndexOf. Можно сделать так, чтобы TStringList хранил список в алфавитном порядке. Чтобы сделать это, то прежде, чем добавить что-то к списку, установите свойство Sorted в True. TStringList может также использоваться для хранения для каждой строки ссылки на объект; осуществить это можно с помощью AddObject и свойства Objects. TList делает вышесказанное, но без строк. Для создания TStringlist сделайте следующее:

procedure MakeList;
var
aList: TStringList;
begin
aList := TStringList.Create;
aList.Sorted := true;  {опционально}
aList.Duplicates := dupIgnore;  {или dupAccept, или dupError}
aList.Add('Строка 1');
aList.Add('Строка 2');
Edit1.Text := aList.Items[0];   {Edit1 теперь содержит 'Строка 1'}
aList.Delete(0);
aList.Free;
end;

[001635]


Delphi 3

Ошибка 'EOLESYS..OPERATION UNAVAILABLE' (операция недоступна) при использовании GETACTIVEOLEOBJECT

Это происходит при использовании сервера автоматизации Delphi, или когда сервер автоматизации (например, word.basic) не запущен.

procedure TForm1.Button1Click(Sender: TObject);
var
V: OleVariant;
begin
V := GetActiveOleObject('Word.Basic');
V.FileNew;
V.Insert('тест');
end;

GetActiveOleObject определен в ComObj.pas. Он преобразует имя класса в guid и передает его при вызове Windows api функции GetActiveObject.

function GetActiveOleObject(const ClassName: string): IDispatch;
var
ClassID: TCLSID;
Unknown: IUnknown;
begin
ClassID := ProgIDToClassID(ClassName);
OleCheck(GetActiveObject(ClassID, nil, Unknown));
OleCheck(Unknown.QueryInterface(IDispatch, Result));
end;

GetActiveOleObject использует интерфейс с именем IRunningObjectTable. Мы не регистрируем это автоматически в таблице, поэтому, чтобы воспользоваться его функциональным назначением, вы должны получить этот интерфейс и использовать его методы для регистрации. [001139]


Delphi 3

Ошибка 'TACTIVEFORMX DECLARATION MISSING OR INCORRECT' (определение TACTIVEFORMX отсутствует или неправильно)

Обычно это происходит при неправильном порядке изменения имени ActiveForm (смотри README.TXT). Если сначала изменяется имя CoClass, а затем делается обновление (refresh), возникает AV. При дальнейшей попытке изменить имя в Инспекторе Объектов вы получите ошибку "TActiveFormX declaration missing or incorrect" (определение TActiveFormX отсутствует или неправильно). Для решения проблемы откройте .DFM-файл и измените строчку:

object ActiveFormX: TActiveFormX

на

object MyForm: TMyForm

[001141]


Delphi 3

Лицензирование активных форм и ActiveX

Почему ACTIVEX и активные формы иногда не отображаются в INTERNET EXPLORER? Все, что появляется, это .HTM-страница с пустым квадратом и красным "X" в нем.

Вероятно, при создании ActiveForm вы выбрали опцию лицензирования и не поместили .LIC-файл в ваш .OCX-файл. Обычно с ActiveForms/ActiveXs лицензирование не используется, поскольку активные элементы в основном используются для повышения привлекательности Интернет-сервера и "распространяются" свободно. Чтобы выключить лицензию времени разработки (Design-Time Licensing), найдите секцию initialization в вашем ActiveForm XXXImpl-файле и замените предпоследний параметр вызова TActiveXControlFactory.Create на пустую строку:

initialization
TActiveXControlFactory.Create( ComServer, TAnimateX, TAnimate, Class_AnimateX, 1, '', 0);
end.

Так когда мне нужно будет использовать Design-Time Licensing?

Ваш элемент управления должен использовать design-time-лицензию только в случае, если вы продаете ActiveX или ActiveForm другим разработчикам, которые встраивают их в продаваемые ими приложения для конечных пользователей. То есть, элемент управления работает в среде разработки (например, Delphi, C++Builder, VB и пр.) только когда LIC-файл присутствует, но это не работает когда .LIC-файл отсутствует во время выполнения приложения без среды разработки (например, в приложении для конечного пользователя).

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

Кроме того, для показа ActiveForm необходимо установить в Internet Explorer уровень "Active content security" (безопасность активного содержимого) в medium (средняя). Чтобы это сделать, войдите в Панель Управления и щелкните на иконке Internet. Перейдите на страницу безопасности и нажмите на кнопку "Safety Level" (уровень безопасности). Убедитесь в том, что уровень находится на отметке "средний".

Примечание: Данный совет отностится только если вы разрабатываете собственные элементы управления. Потенциально хакерские элементы ActiveX могут нанести вред компьютеру! [001143]


Delphi 3

Добавление IPERSISTPROPERTYBAG к активным элементам управления

Данный совет рассказывает о том, как можно добавить интерфейс IPersistPropertyBag к элементу управления ActiveX. Существует возможность установки свойств элемента управления ActiveX с помощью HTML тэгов PARAM. Добавление интерфейса IPersistPropertyBag в элемент управления ActiveX также позволяет изменять его свойства с помощью инструментов типа ActiveX Control Pad.

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

Начнем с использования ActiveX Control Wizard и создадим элемент управления ActiveX на основе TButton.

Активизируйте пункт меню File|New и выберите в диалоге New Item (новый элемент) закладку ActiveX. Затем в списке выберите элемент "ActiveX Control". В появившемся диалоговом окне выберите TButton для VCL Class Name. Все остальные настройки можете не трогать и оставить как есть. После нажатия на кнопку OK Delphi сгенерирует базовый код для вашего элемента управления.

Следующим шагом будет добавление интерфейса IPersistPropertyBag к определению класса. Измените первую строку определения, декларирующую тип...

type
TButtonX = class(TActiveXControl, IButtonX)

на...

type
TButtonX = class(TActiveXControl, IButtonX, IPersistPropertyBag)

Теперь интерфейс IPersistPropertyBag добавлен к объявлению типа. Затем объявите необходимые методы, добавляя следующие строки в секцию protected:

function IPersistPropertyBag.InitNew = PersistPropBagInitNew;
function IPersistPropertyBag.Load = PersistPropBagLoad;
function IPersistPropertyBag.Save = PersistPropBagSave;
function PersistPropBagInitNew: HResult; stdcall;
function PersistPropBagLoad(const pPropBag: IPropertyBag;
const pErrorLog: IErrorLog): HResult; stdcall;
function PersistPropBagSave(const pPropBag: IPropertyBag;
fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult;
stdcall;

Затем, конечно, реализуйте эти функции...

// -- реализация PersistPropBagInitNew

function TButtonX.PersistPropBagInitNew: HResult;
begin
Result := S_OK;
end;

// -- реализация PersistPropBagLoad
function TButtonX.PersistPropBagLoad(const pPropBag:
IPropertyBag; const pErrorLog: IErrorLog): HResult; stdcall;
var
v: OleVariant;
begin
if pPropBag.Read('Caption', v, pErrorLog) = S_OK then
FDelphiControl.Caption := v;
Result := S_OK;
end;

// -- реализация PersistPropBagSave

function TButtonX.PersistPropBagSave(const pPropBag:
IPropertyBag; fClearDirty: BOOL; fSaveAllProperties: BOOL)
: HResult; stdcall;
var
v: OleVariant;
begin
v:= FDelphiControl.Caption;
pPropBag.Write('Caption', v);
Result := S_OK;
end;

Добавлением этого кода завершается создание элемента управления. Продолжаем дальше: соберите (build) элемент управления ActiveX и разместите его в сети. Сделайте это с помощью мастера Web Delpoy Wizard. Просто сделайте необходимые настройки на странице Project|Web Delpoyment Options и разместите ActiveX через Project| Web Deploy.

Мастер Web Deployment Wizard создаст HTML-страницу, содержащую тэг OBJECT, которая должна выглядеть приблизительно так:

<OBJECT
          classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306"
          codebase="ActiveX/ButtonXControl.ocx"
          width=100
          height=50
          align=center
          hspace=0
          vspace=0
>
</OBJECT>
Эта страница должна заработать без проблем. Тем не менее, теперь у вас имеется возможность задания заголовка для кнопок через HTML простым добавлением тэга PARAM. Вам измененный тэг OBJECT должен выглядеть таким образом:
<OBJECT
          classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306"
          codebase="ActiveX/ButtonXControl.ocx"
          width=100
          height=50
          align=center
          hspace=0
          vspace=0
>
<Param Name="Caption" Value="Привет">
</OBJECT>
Заголовок кнопки теперь будет говорить вам "Привет". В нашем примере заголовок будет доступен только с помощью данного метода. Для того, чтобы рулить другими свойствами, следуйте нашему примеру и изменяйте имя свойства, которое вы хотите использовать. [001145]


Delphi 1

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

Это код, который я использую для установки chartfx.

chart1.Opendata[cod_values]:=makelong(no_of_series,no_of_classes);

{установка последовательных значений}

chart1.closedata[cod_values]:=0;

unit TstChart;

interface

uses=20
WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Menus,
Dialogs, StdCtrls, Buttons, ExtCtrls, Tabs,
ChartFX, {Похоже, действительно необходимо включить этот модуль
в список, чтобы иметь доступ к константам, например к COD_VALUES}
VBXCtrl, Chart2fx;

type
TF_Chart =3D class(TForm)
SpeedPanel: TPanel;
ExitBtn: TSpeedButton;
NB: TNotebook;
TB: TTabSet;
Chart1: TChartFX;
Chart2: TChartFX;
procedure ExitItemClick(Sender: TObject);
procedure FormCreate(Sender: TObject);

procedure TBClick(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Procedure Build1( Ch : TChartFX );
Procedure Build2( Ch : TChartFX );
end;

var
F_Chart: TF_Chart;

implementation

{$R *.DFM}

procedure TF_Chart.ExitItemClick(Sender: TObject);
begin
Close;
end;

procedure TF_Chart.FormCreate(Sender: TObject);
begin
TB.Tabs :=3D NB.Pages;

NB.PageIndex :=3D 0;
Build1( Chart2 );
Build2( Chart2 ); {добавляем значения для Chart2: length... и т.д.}
end;

procedure TF_Chart.TBClick(Sender: TObject);
begin
NB.PageIndex :=3D TB.TabIndex;
end;

Procedure TF_Chart.Build1( Ch : TChartFX );
begin
{Эта процедура изменяет свойства, которые могут устанавливаться во время разработки или временя выполнения. В коментариях подробно указано чем занимается метод Design}

with Ch do begin

Adm[ CSA_GAP ] :=3D 25.0;

{Design:   Используйте свойство AdmDlg для изменения координаты Y}

pType :=3D BAR or CT_LEGEND;
{Design: Изменяем свойство ChartType с 1 - line
на 2 - bar.}
DecimalsNum[ CD_YLEG ] :=3D 0;
{Design: Изменяем свойство Decimals с 2 до 0}

Stacked :=3D CHART_STACKED;
{Design: Изменяем свойство Stacked с 0 - None на 1 - Normal}

RightGap :=3D 20;
{Design: Тоже}

OpenData[ COD_COLORS ] :=3D 2;

Color[ 0 ] :=3D clBlack;
Color[ 1 ] :=3D clYellow;
CloseData[ COD_COLORS ] :=3D 0; {Фу!!}
{Design: Для изменения цветов 2 серий:
1)  Убедитесь, что ThisSerie установлен в 0.  Измените
ThisColor на clBlack.
2)  Установите ThisSerie в 1.  Измените ThisColor на
clYellow.}
Title[ CHART_TOPTIT ] :=3D 'Статьи и заголовки';
Title[ CHART_LEFTTIT ] :=3D 'CCM';
Title[ CHART_BOTTOMTIT ] :=3D 'Карты';
{Design:  щелкните на свойстве TitleDlg и
установите верхний, левый и нижний заголовки}
end;
end;

Procedure TF_Chart.Build2( Ch : TChartFX );
{Данная процедура устанавливает свойства, которые не могут
(насколько я определил это) быть установлены в режиме разработки}
const
XAbbrevs : array[ 0..4 ] of string[ 4 ] =3D
( 'Acc', 'Bar', 'Mas', 'Amex', 'Din' );
SeriesTitles : array[ 0..1 ] of string[ 8 ] =3D
( 'Статьи', 'Заголовки' );
XTitles : array[ 0..4 ] of string[ 20 ] =3D

( 'Access', 'Barclaycard', 'Mastercard', 'American Express',
'Diners' );
{естественно, вы должны нормально читать из базы данных
xTitles и значения}
Values : array[ 0..1, 0..4 ] of double =3D
( ( 50, 60, 70, 80, 90 ),
( 30, 35, 25, 37, 42 ) );
var
i, SerieNo : integer;
begin
with Ch do begin

LegendWidth :=3D 120;

{Установка количества серий, количества значений ******************}
OpenData[ COD_INIVALUES ] :=3D MAKELONG( 2, 5 );

CloseData[ COD_INIVALUES ] :=3D 0;
{*********************************************************}

OpenData[ COD_VALUES ] :=3D 2;
{если вы пропускаете приведенное выше утверждение, (в котором вы вводите номер SERIES и VALUES), и CloseData ниже, назначение значений не создает ошибки, но и не работает! Назначение значений Legend и KeyLeg работает без OpenData/CloseData}
ThisSerie :=3D 0;
for i :=3D 0 to 1 do

SerLeg[ i ] :=3D SeriesTitles[ i ];
for i :=3D 0 to 4 do=20
begin
Legend[ i ] :=3D XTitles[ i ];
KeyLeg[ i ] :=3D XAbbrevs[ i ];
end;
SerieNo :=3D 0;
for SerieNo :=3D 0 to 1 do=20
begin
ThisSerie :=3D SerieNo;
for i :=3D 0 to 4 do
Value[ i ] :=3D Values[ SerieNo, i ];
end;

CloseData[ COD_VALUES ] :=3D 0;
end;
end;

procedure TF_Chart.FormResize(Sender: TObject);
var
w, h : longint;
begin
w :=3D NB.Width;
H :=3D NB.Height;
{при необходимости увеличиваем/уменьшаем размер диаграммы}
Chart1.Width :=3D W - 18;
Chart1.Height :=3D H - 12;
Chart2.Width :=3D W - 18;
Chart2.Height :=3D H - 12;

{перемещаем кнопку выхода в правый угол}
ExitBtn.Left :=3D SpeedPanel.Width - 32;
end;

end.

[001149]


Delphi 2

CHARTFX - минимум максимум

Так можно сделать с ChartFX в Delphi 2.... Я думаю то же самое будет и в D1...

cfxStockTrends.Adm[CSA_MIN] := X;       //устанавливаем минимум по оси Y
cfxStockTrends.Adm[CSA_MAX] := Y;       //Устанавливаем максимум по оси Y

[001151]


Delphi 1

Пример CHARTFX

Документация, поставляемая с Delphi, слишком запутанна и тяжела, особенно если вы не пользователь VBX...

Следующий пример устанавливает некоторые значения и пр. для ChartFX:

{Код получает данные из базы данных и рисует их}

begin
MyTable.active := True;         {открываем базу данных}
MyTable.first;
MyChart.title[CHART_BOTTOMTIT] := 'Заголовок по оси X';
MyChart.title[CHART_LEFTTIT] := 'Заголовок по оси Y';
MyChart.OpenData[COD_XVALUES] := MakeLong(numOfSeries,numofPoints);
MyChart.OpenData[COD_VALUES] := MakeLong(numOfSeries, NumofPoints);
MyChart.ThisSerie := SeriesNum;         {начинаем с 0}
While MyTable.EOF <> True do
begin
MyChart.value[i] := MyTable.FieldByName('SOMEFIELD').AsFloat;
MyChart.Xvalue[i] := MyTable.FieldByName('SOMEOTHERFIELD').AsFloat;
MyTable.next;
i:=i+1;         {естественно, вам необходимо определить и инициализировать 'i'}
end;
MyChart.CloseData[COD_Values] := 0;
MyChart.CloseData[COD_XValues] := 0;
MyTable.active := False;         {закрываем базу данных}
end;

{Обратите внимание на то, что данный код отностится к диаграмме типа xy scatter. Если вы хотите сменить тип диаграммы ChartFX, вам не нужно устанавливать значения для COD_XVALUES}

[001153]


Управление свойством Font через сервер автоматизации

Данный документ предназначен главным образом тем программистам, кто использует OLE/COM и хочет встроить объект Font (типа Delphi-го TFont) в свой сервер автоматизации. Интерфейс IFontDisp для COM будет иметь ту же функциональность, что и Delphi-ий TFont. Например, если у вас имеется клиент автоматизации, содержащий объект со свойством Font, и в сервере автоматизации для изменения атрибутов текста вы хотите иметь те же методы (наприр, имя шрифта, жирное или наклонное начертание). Для хранения и управления шрифтом сервер автоматизации может применять реализацию интерфейса IFontDisp.

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

Демонстрационный проект содержит следующие модули:

Project1_TLB: Паскалевская обертка для библиотеки типов, содержащей определение интерфейса.

Unit1: Реализация интерфейса: код, содержащий описание свойств интерфейса и реализующий его методы.

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

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

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

  1. Выберите пункт меню File|New|ActiveX|Automation Object и в Мастере Automation Object Wizard выберите в качестве имени класса MyFontServer. Создайте единственное свойство с именем MyFont и типом IFontDisp. Для получения дополнительной информции смотри Developer's Guide, chapter 42 (руководство разработчика, глава 42), там подробно описана работа с библиотеками типов и создание интерфейсов в редакторе библиотеки типов.
  2. В предыдущем шаге при добавлении интерфейса с помошью редактора библиотеки типов вы должны были получить паскалевский модуль-обертку (в нашем примере модуль имеет имя Unit1). Unit1 будет содержать обертку реализаций методов получения и назначения свойства MyFont. На данном этапе вы обеспечите хранение значений свойства MyFont в форме FFont (TFont) и добавите код реализации, наполняющий функциональностью методы получения и установки (get/set).

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

  3. Создайте Unit2, содержащий форму с компонентами TMemo и TStatusBar. Форма используется для отображения жизнедеятельности в модуле Unit1.pas. Это шаг не является строго обязательным, он помогает понять что происходит в данный момент между клиентом автоматизации и сервером.
  4. Создайте клиент автоматизации. В нашем случае модуль имеет имя FontCli, содержит метку, показывающую текущий шрифт и кнопку, устанавливающую MyFont на сервере.
unit Project1_TLB;

{ Данный файл содержит паскалевские декларации, импортированные из библиотеки типов. Данный файл записывается во время каждого импорта или обновления (refresh) в редакторе библиотеки типов. Любые изменения в данном файле будут потеряны в процессе очередного обновления. }

{ Библиотека Project1 }
{ Версия 1.0 }

 interface

uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL;

const
LIBID_Project1: TGUID = '{29C7AC94-0807-11D1-B2BA-0020AFF2F575}';

const

{ GUID'ы класса компоненты }
Class_MyFontServer: TGUID = '{29C7AC96-0807-11D1-B2BA-0020AFF2F575}';

type

{ Предварительные объявления: Интерфейсы }
IMyFontServer = interface;
IMyFontServerDisp = dispinterface;

{ Предварительные объявления: CoClasse'ы }
MyFontServer = IMyFontServer;

{ Диспинтерфейс для объекта MyFontServer }
IMyFontServer = interface(IDispatch)
['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
function Get_MyFont: IFontDisp; safecall;
procedure Set_MyFont(const Value: IFontDisp); safecall;
property MyFont: IFontDisp read Get_MyFont write Set_MyFont;
end;

{ Объявление диспинтерфейса для дуального интерфейса IMyFontServer }
IMyFontServerDisp = dispinterface
['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
property MyFont: IFontDisp dispid 1;
end;

{ MyFontServerObject }

CoMyFontServer = class
class function Create: IMyFontServer;
class function CreateRemote(const MachineName: string): IMyFontServer;
end;

implementation

uses ComObj;

class function CoMyFontServer.Create: IMyFontServer;
begin
Result := CreateComObject(Class_MyFontServer) as IMyFontServer;
end;

class function CoMyFontServer.CreateRemote(const MachineName: string):
IMyFontServer;
begin
Result := CreateRemoteComObject(MachineName, Class_MyFontServer) as
IMyFontServer;
end;

end.
{--------------------------------------------------------------------}

unit Unit1;

interface

uses
ComObj, Project1_TLB, ActiveX, Graphics;

type
TMyFontServer = class(TAutoObject, IMyFontServer)
private
FFont: TFont;
public
procedure Initialize; override;
destructor Destroy; override;
function Get_MyFont: IFontDisp; safecall;
procedure Set_MyFont(const Value: IFontDisp); safecall;
end;

implementation

uses ComServ, AxCtrls, Unit2;

procedure TMyFontServer.Initialize;
begin
inherited Initialize;
FFont := TFont.Create;
end;

destructor TMyFontServer.Destroy;
begin
FFont.Free;
inherited Destroy;
end;

function TMyFontServer.Get_MyFont: IFontDisp;
begin
FFont.Assign(Form2.Label1.Font);
GetOleFont(FFont, Result);
end;

procedure TMyFontServer.Set_MyFont(const Value: IFontDisp);
begin
SetOleFont(FFont, Value);
Form2.Label1.Font.Assign(FFont);
end;

initialization
TAutoObjectFactory.Create(ComServer, TMyFontServer, Class_MyFontServer,
ciMultiInstance);
end.
{--------------------------------------------------------------------}

unit Unit2;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm2 = class(TForm)
Label1: TLabel;
end;

var
Form2: TForm2;

implementation

{$R *.DFM}

end.
{--------------------------------------------------------------------}

unit FontCli1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StdVCL, Project1_TLB;

type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
FontDialog1: TFontDialog;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
public
MyFontServer: IMyFontServer;
end;

var
Form1: TForm1;

implementation

uses ActiveX, AxCtrls;

{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
Temp: IFontDisp;
begin
if (FontDialog1.Execute) then
begin
Label1.Font.Assign(FontDialog1.Font);
GetOleFont(Label1.Font, Temp);
MyFontServer.Set_MyFont(Temp);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MyFontServer := CoMyFontServer.Create;
end;

end.
{--------------------------------------------------------------------}

Так для чего нам Unit1, создающий реализацию интерфейса? Интерфейс Ole, такой как, например, IFontDisp, может считаться соглашением о том, что свойства и функции будут определены в заданном формате, а функции будут реализованы как определено (для получения дополнительной информации смотри Руководство Разработчика, главу 36, "An Overview of COM" (Обзор COM). Тот факт, что интерфейс определен, не означает, что он реализован. Например, чтобы заставить определенный вами интерфейс IFontDisp быть полезным, необходимо обеспечить хранение шрифта и механизм добавления и извлечения информации об атрибутах шрифта, таких, как имя шрифта, наклонное начертание, размер и пр.

Примечание:
GetOleFont и SetOleFont определены в AxCtrls.pas. IFontDisp определен в ActiveX.pas [001155]


Delphi 1

Использование CHARTFX.VBX

Хотя это можно было бы пообсуждать и здесь, но для ChartFX существует контекстно-зависимая подсказка. Киньте компонент на форму, выберите его и нажмите F1. [001157]


Delphi 1

VBX в приложениях DELPHI: как распространять?

Чтобы использовать любые элементы управления VBX с компилированным Delphi EXE-файлом, вам необходимо распространить BIVBX11.DLL (расположен в каталоге \WINDOWS\SYSTEM - Borland при установке копирует его туда). [001159]


Расскажите, как использовать ChartFX?

Nomadic советует:

Лyчше на пpостеньком пpимеpе.

unit Chart;
.......................
with ChartFX do
begin
Visible := false;
{ Устанавливаем режим ввода значений }
{ 1 - количество серий (в нашем случае 1), 3 - количество значений }
OpenData [COD_VALUES] := MakeLong(1,3);
{ Hомер текущей серии }
ThisSerie := 0;
{ Value [i] - значение с индексом i }
{ Legend [i] - комментарий к этому значению }
Value [0] := a;
Legend [0] := 'Значение переменной A';
Value [1] := b;
Legend [1] := 'Значение переменной B';
Value [2] := c;
Legend [2] := 'Значение переменной C';
{ Закрываем режим }
CloseData [COD_VALUES] := 0;
{ Ширина поля с комментариями на экране (в пикселах) }
LegendWidth := 150;
Visible := true;
end;
end;

end.

[001210]


Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch?

Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?

Nomadic советует:

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

const
MyGUID = '{444...111}'; //Whatever the guid is...

var
Unk: IUnknown;
Disp: IDispatch;

begin

{ Make sure this line works correctly }
Unk := CreateRemoteComObject('server1',
StringToGUID(MyGUID));

{ If it does, then cast it to a IDispatch }
Disp := Unk as IDispatch;

end;

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


В чем разница между сокетами, DCOM и OLE Enterprise при использовании их в качестве транспорта?

Nomadic отвечает:

Sockets (TCP/IP):

  • на клиентах и сервере требуется наличие стека TCP/IP;
  • не требуется дополнительной настройки клиентов;
DCOM:
  • на клиентах и серверах требуется наличие DCOM (входит в состав Windows NT 4.0, для Windows 95 доступен как опция)
  • требуется настройка клиентов (DCOM Configuration Utility - DCOMCNFG.EXE);
  • встроенная поддержка модели безопасности Windows NT;
  • поддержка обратных вызовов (методов);
CORBA
  • на клиентах и серверах требуется наличие Common Object Request Broker;
  • требуется настройка клиентов;
  • поддержка обратных вызовов (методов);
OLE Enterprise:
  • на клиентах и серверах требуется наличие OLE Enterprise;
  • требуется настройка клиентов;
  • поддержка обратных вызовов (методов).
[001454]


Delphi 1

DDE - передача текста

Вот я как работаю с Excel:

type
DDEClientConv1.SetLink('Excel','Sheet1');
try
DDEClientConv1.OpenLink;
DDEClientItem1.DDEItem:= 'R1C1';
DDEClientConv1.PokeData(DDEClientItem1.DDEItem,
StrPCopy(P, SomeString)));
finally
DDEClientConv1.CloseLink;
end;

Как вы можете здесь видеть, свойство DDEItem определяется сервером. Если ваш сервер является приложением Delphi, то DDEItem - имя DDEServerItem. На вашем месте я бы не стал так долго заниматься отладкой DDE-программ. Воспользуйтесь синхронизацией, позволяющей понять при отладке правильность действий. [001419]


Delphi 1

Управление Program Manager в Win95 с помощью DDE

Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide.

Работает под Win 3.1 и '95.

unit Pm;

interface

uses
SysUtils, Classes, DdeMan;

type
EProgManError = class(Exception);

TProgMan = class(TComponent)
private
FDdeClientConv: TDdeClientConv;
procedure InitDDEConversation;
function ExecMacroString(Macro: String): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure CreateGroup(GroupName: String; ShowGroup:Boolean);
procedure DeleteGroup(GroupName: String);
procedure DeleteItem(ItemName: String);
procedure AddItem(CmdLine, ItemName: String);
end;

implementation

uses Utils;

const
{ DDE-макростроки для Program Manager }
SDDECreateGroup   = '[CreateGroup(%s)]';
SDDEShowGroup     = '[ShowGroup(%s, 1)]';
SDDEDeleteGroup   = '[DeleteGroup(%s)]';
SDDEDeleteItem    = '[DeleteItem(%s)]';
SDDEAddItem       = '[AddItem(%s, "%s", %s)]';

constructor TProgMan.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitDDEConversation;
end;

destructor TProgMan.Destroy;
begin
if Assigned(FDDEClientConv) then
FDdeClientConv.CloseLink;
inherited Destroy;
end;

function TProgMan.ExecMacroString(Macro: String): Boolean;
Begin
StringAsPchar(Macro);
Result := FDdeClientConv.ExecuteMacro(@Macro[1], False);
End;

Procedure TProgMan.InitDDEConversation;
begin
FDdeClientConv := TDdeClientConv.Create(Self);
If NOT FDdeClientConv.SetLink('PROGMAN', 'PROGMAN') then
raise EProgManError.Create('Не могу установить DDE Link');
end;

Procedure TProgMan.CreateGroup(GroupName: String; ShowGroup:Boolean);
Begin
{ Удаляем группу, если она существует }
ExecMacroString(Format(SDDEDeleteGroup, [GroupName]));

If NOT ExecMacroString(Format(SDDECreateGroup, [GroupName])) then
raise EProgManError.Create('Не могу создать группу ' + GroupName);
If ShowGroup then
If not ExecMacroString(Format(SDDEShowGroup, [GroupName])) then
raise EProgManError.Create('Не могу показать группу ' + GroupName);
End;

Procedure TProgMan.DeleteGroup(GroupName: String);
Begin
if NOT ExecMacroString(Format(SDDEDeleteGroup, [GroupName])) then
raise EProgManError.Create('Не могу удалить группу ' + GroupName);
End;

Procedure TProgMan.DeleteItem(ItemName: String);
Begin
if NOT ExecMacroString(Format(SDDEDeleteGroup, [ItemName])) then
raise EProgManError.Create('Не могу удалить элемент ' + ItemName);
End;

Procedure TProgMan.AddItem(CmdLine, ItemName: String);
Var
P: PChar;
PSize: Word;
Begin
PSize := StrLen(SDDEAddItem) + (Length(CmdLine) *2) + Length(ItemName) + 1;
GetMem(P, PSize);
try
StrFmt(P, SDDEAddItem, [CmdLine, ItemName, CmdLine]);
if NOT FDdeClientConv.ExecuteMacro(P, False) then
raise EProgManError.Create('Не могу добавить элемент ' + ItemName);
finally
FreeMem(P, PSize);
end;
End;

end.

[001421]


Delphi 1

GROUPFILE и ADDITEM для групп

Вот код для создания файла группы и добавления в группу файла-элемента. Чтобы использовать эту процедуру, определите DDE clientconv App как ProgMan.

procedure TMainForm.CreateWinGroup(Sender: TObject);
var
Name: string;
Name1: string;
Macro: string;
Macro1: string;
Cmd, Cmd1: array[0..255] of Char;
begin
{destDir - dos-каталог, хранящий YourFile.Ext'}
Name := 'GroupName';
Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';
Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
Macro1 :=Format('[Additem(%s)]',[Name1]) +#13#10;
StrPCopy (Cmd, Macro);
StrPCopy (cmd1, Macro1);
DDEClient.OpenLink;
if not DDEClient.ExecuteMacro(Cmd, False) then
MessageDlg('Невозможно создать группу '+Name,mtInformation, [mbOK], 0)
else
begin
DDEClient.ExecuteMacro(Cmd1, False);
end;
DDEClient.CloseLink;

end;

[001423]


Delphi 3

Как можно работать с DDE под Delphi, используя вызовы API?

Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.

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

  1. Клиент может "пропихивать" (POKE) данные на сервер.
  2. Сервер может автоматически передавать данные клиенту, после чего клиент обновляет свой вид на основе результатов, полученных от сервера.
  3. Данные сервера изменяются, после чего клиент делает запрос серверу для получения новых данных и обновляет свой вид.
Как работает программа.

Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру:
{ *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** },
поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi

{ *** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;

uses
Forms,
Ddemlclu in 'DDEMLCLU.PAS' {Form1};

{$R *.RES}

begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLCLI.DPR *** }

{ *** НАЧАЛО КОДА DDEMLCLU.DFM *** }
object Form1: TForm1
Left = 197
Top = 95
Width = 413
Height = 287
HorzScrollBar.Visible = False
VertScrollBar.Visible = False
Caption = 'Демонстрация DDEML, Клиентское приложение'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object PaintBox1: TPaintBox
Left = 0
Top = 0
Width = 405
Height = 241
Align = alClient
Color = clWhite
ParentColor = False
OnPaint = PaintBox1Paint
end
object MainMenu1: TMainMenu
Top = 208
object File1: TMenuItem
Caption = '&Файл'
object exit1: TMenuItem
Caption = 'В&ыход'
OnClick = exit1Click
end
end
object DDE1: TMenuItem
Caption = '&DDE'
object RequestUpdate1: TMenuItem
Caption = '&Запрос на обновление'
OnClick = RequestUpdate1Click
end
object AdviseofChanges1: TMenuItem
Caption = '&Сообщение об изменениях'
OnClick = AdviseofChanges1Click
end
object N1: TMenuItem
Caption = '-'
end
object PokeSomeData: TMenuItem
Caption = '&Пропихивание данных'
OnClick = PokeSomeDataClick
end
end
end
end
{ ***  КОНЕЦ КОДА DDEMLCLU.DFM *** }

{ *** НАЧАЛО КОДА DDEMLCLU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Это демонстрационное приложение, демонстрирующее использование DDEML API в клиентском приложении. Оно использует серверное приложение DataEntry, которое является частью данной демонстрации, и служит для ввода данных и отображения их на графической панели.

Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS), а затем стартовать клиента. Если сервер не запущен, клиент при попытке соединения потерпит неудачу.

Интерфейс сервера определен списком имен (Service, Topic и Items) в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер делает Items доступными в формате cf_Text; они преобразовываются и хранятся локально как целые. }
unit Ddemlclu;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;

const
NumValues = 3;

type

{ Структура данных, представленная в примере }
TDataSample = array [1..NumValues] of Integer;
TDataString = array [0..20] of Char;     { Размер элемента как текста }

{ Главная форма }
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
exit1: TMenuItem;
DDE1: TMenuItem;
RequestUpdate1: TMenuItem;
AdviseofChanges1: TMenuItem;
PokeSomeData: TMenuItem;
N1: TMenuItem;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RequestUpdate1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure AdviseofChanges1Click(Sender: TObject);
procedure PokeSomeDataClick(Sender: TObject);

procedure Request(HConversation: HConv);
procedure exit1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);

private
{ Private declarations }
public
Inst: Longint;
CallBackPtr: ^TCallback;
ServiceHSz : HSz;
TopicHSz  : HSz;
ItemHSz    : array [1..NumValues] of HSz;
ConvHdl    : HConv;

DataSample : TDataSample;
end;

var Form1: TForm1;

implementation

const
DataEntryName : PChar = 'DataEntry';
DataTopicName : PChar = 'SampledData';
DataItemNames : array [1..NumValues] of pChar = ('DataItem1',
'DataItem2',
'DataItem3');
{$R *.DFM}

{ Локальная функция: Процедура обратного вызова для DDEML }

function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin
CallbackProc := 0;    { В противном случае смотрите доказательство }

case CallType of
xtyp_Register:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Unregister:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_xAct_Complete:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Request, Xtyp_AdvData:
begin
Form1.Request(Conv);
CallbackProc := dde_FAck;
end;
xtyp_Disconnect:
begin
ShowMessage('Соединение разорвано!');
Form1.Close;
end;
end;
end;

{ Посылка DDE запроса для получения cf_Text данных с сервера. Запрашиваем данные для всех полей DataSample, и обновляем окно для их отображения. Данные с сервера получаем синхронно, используя DdeClientTransaction.}

procedure TForm1.Request(HConversation: HConv);
var
hDdeTemp : HDDEData;
DataStr  : TDataString;
Err, I  : Integer;
begin
if HConversation <> 0 then begin
for I := Low(ItemHSz) to High(ItemHSz) do begin
hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
cf_Text, xtyp_Request, 0, nil);
if hDdeTemp <> 0 then  begin
DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, DataSample[I], Err);
end; { if }
end; { for }
Paintbox1.Refresh; { Обновляем экран }
end; { if }
end;

procedure TForm1.FormCreate(Sender: TObject);
var
I : Integer;
{ Создаем экземпляр окна DDE-клиента. Создаем окно, используя унаследованный конструктор, инициализируем экземпляр данных.}
begin
Inst       := 0;      { Должен быть нулем для первого вызова DdeInitialize }
CallBackPtr:= nil;    { MakeProcInstance вызывается из SetupWindow    }
ConvHdl    := 0;
ServiceHSz := 0;
TopicHSz   := 0;
for I := Low(DataSample) to High(DataSample) do begin
ItemHSz[I]    := 0;
DataSample[I] := 0;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы DDE строк, и освобождаем экземпляр функции обратного вызова, если она существует. Также, для завершения диалога, вызовите DdeUninitialize. Затем, для завершения работы, вызовите разрушителя предка. }
var I : Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);
for I := Low(ItemHSz) to High(ItemHSz) do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);

if Inst <> 0 then
DdeUninitialize(Inst);   { Игнорируем возвращаемое значение }

if CallBackPtr <> nil then
FreeProcInstance(CallBackPtr);
end;

procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
{ Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}
Request(ConvHdl);
end;

procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия, которые требует правильное окно. Инициализируем использование DDEML. }
 var
I     : Integer;
InitOK: Boolean;
begin
CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);

{ Инициализируем DDE и устанавливаем функцию обратного вызова. Если сервер отсутствует, вызов терпит неудачу. }
if CallBackPtr <> nil then begin
if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,
0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz  := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
InitOK := True;
{     for I := Low(DataItemNames) to High(DataItemNames) do begin }
for I := 1 to NumValues do begin
ItemHSz[I]:= DdeCreateStringHandle(Inst, DataItemNames[I],
cp_WinAnsi);
InitOK := InitOK and (ItemHSz[I] <> 0);
end;

if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then begin
ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
if ConvHdl = 0 then begin
ShowMessage('Не могу инициализировать диалог!');
Close;
end
end
else begin
ShowMessage('Не могу создать строки!');
Close;
end
end
else begin
ShowMessage('Не могу осуществить инициализацию!');
Close;
end;
end;
end;

procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE | Advise (уведомление). При выборе этого пункта меню все три элемента переключаются на уведомление. }
 var
I: Integer;
TransType: Word;
TempResult: Longint;
begin
with TMenuITem(Sender) do begin
Checked := not Checked;
if Checked then
TransType:= (xtyp_AdvStart or xtypf_AckReq)
else
TransType:= xtyp_AdvStop;
end; { with }

for I := Low(ItemHSz) to High(ItemHSz) do
if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
TransType, 1000, @TempResult) = 0 then
ShowMessage('Не могу выполнить транзакцию-уведомление');

if TransType and xtyp_AdvStart <> 0 then Request(ConvHdl);
end;

procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта меню DDE | Poke. Запрашиваем значение у пользователя, которое будем "проталкивать" в DataItem1 в качестве иллюстрации Poke-функции.}
var
DataStr: pChar;
S: String;
begin
S := '0';
if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then begin
S := S + #0;
DataStr := @S[1];
DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
Request(ConvHdl);
end;
end;

procedure TForm1.exit1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
const
LMarg = 30;    { Левое поле графика }
var
I,
Norm: Integer;
Wd: Integer;
Step : Integer;

ARect: TRect;

begin
Norm := 0;
for I := Low(DataSample) to High(DataSample) do begin
if abs(DataSample[I]) > Norm then
Norm := abs(DataSample[I]);
end; { for }

if Norm = 0 then Norm := 1;  { В случае если у нас все нули }

with TPaintBox(Sender).Canvas do begin
{ Рисуем задний фон }
Brush.color  := clWhite;
FillRect(ClipRect);

{ Рисуем ось }
MoveTo(0, ClipRect.Bottom div 2);
LineTo(ClipRect.Right, ClipRect.Bottom div 2);

MoveTo(LMarg, 0);
LineTo(LMarg, ClipRect.Bottom);

{ Печатаем текст левого поля }
TextOut(0,0, IntToStr(Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));

TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
{ Печатаем текст оси X }

{ Теперь рисуем бары на основе нормализованного значения. Вычисляем ширину баров (чтобы они все вместились в окне) и ширину пробела между ними, который приблизительно равен 20% от их ширины. }
{        SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
SetBkMode(PaintDC, Transparent);
}
ARect := ClipRect;
Wd  := (ARect.Right - LMarg) div NumValues;
Step := Wd div 5;
Wd  := Wd - Step;
with ARect do begin
Left := LMarg + (Step div 2);
Top := ClipRect.Bottom div 2;
end; { with }

{ Выводим бары и текст для оси X }
For i := Low(DataSample) to High(DataSample) do begin
with ARect do begin
Right := Left + Wd;
Bottom:= Top - Round((Top-5) * (DataSample[I] / Norm));
end; { with }
{ Заполняем бар }
Brush.color  := clFuchsia;
FillRect(ARect);
{ Выводим текст для горизонтальной оси }
Brush.color  := clWhite;
TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
StrPas(DataItemNames[i]));
with ARect do
Left := Left + Wd + Step;
end; { for }
end; { with }
end;
end.{ ***  КОНЕЦ КОДА DDEMLCLU.PAS *** }

{ *** НАЧАЛО КОДА DDEMLSVR.DPR *** }
program Ddemlsvr;

uses
Forms,
Ddesvru in 'DDESVRU.PAS' {Form1},
Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};

{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TDataEntry, DataEntry);
Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLSVR.DPR *** }

{ *** НАЧАЛО КОДА DDESVRU.DFM *** }
object Form1: TForm1
Left = 712
Top = 98
Width = 307
Height = 162
Caption = 'Демонстрация DDEML, Серверное приложение'
Color = clWhite
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object Label1: TLabel
Left = 0
Top = 0
Width = 99
Height = 16
Caption = 'Текущие значения:'
end
object Label2: TLabel
Left = 16
Top = 24
Width = 74
Height = 16
Caption = 'Data Item1:'
end
object Label3: TLabel
Left = 16
Top = 40
Width = 74
Height = 16
Caption = 'Data Item2:'
end
object Label4: TLabel
Left = 16
Top = 56
Width = 74
Height = 16
Caption = 'Data Item3:'
end
object Label5: TLabel
Left = 0
Top = 88
Width = 265
Height = 16
Caption = 'Выбор данных | Ввод данных для изменения значений.'
end
object Label6: TLabel
Left = 96
Top = 24
Width = 8
Height = 16
Caption = '0'
end
object Label7: TLabel
Left = 96
Top = 40
Width = 8
Height = 16
Caption = '0'
end
object Label8: TLabel
Left = 96
Top = 56
Width = 8
Height = 16
Caption = '0'
end
object MainMenu1: TMainMenu
Left = 352
Top = 24
object File1: TMenuItem
Caption = '&Файл'
object Exit1: TMenuItem
Caption = '&Выход'
OnClick = Exit1Click
end
end
object Data1: TMenuItem
Caption = '&Данные'
object EnterData1: TMenuItem
Caption = '&Ввод данных'
OnClick = EnterData1Click
end
object Clear1: TMenuItem
Caption = '&Очистить'
OnClick = Clear1Click
end
end
end
end
{ ***  КОНЕЦ КОДА DDESVRU.DFM *** }

{ *** НАЧАЛО КОДА DDESVRU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

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

Данный сервер предоставляет свои услуги (сервисы) для данных со следующими именами:

Service: 'DataEntry'
Topic  : 'SampledData'
Items  : 'DataItem1', 'DataItem2', 'DataItem3'

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

Вы должны запустить этот сервер ПЕРЕД тем как запустите клиента (DDEMLCLI.PAS), в противном случае клиент не сможет установить связь.

Интерфейс для этого сервера определен как список имен (Service, Topic и Items) в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер делает Items доступными в формате cf_Text; они преобразовываются и хранятся у клиента локально как целые. }
unit Ddesvru;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Menus,

DDEML,     { DDE APi }
ShellApi;

const
NumValues = 3;
DataItemNames : array [1..NumValues] of PChar = ('DataItem1',
'DataItem2',
'DataItem3');
type
TDataString = array [0..20] of Char;      { Размер элемента как текста }
TDataSample = array [1..NumValues] of Integer;

{type
{ Структура данных, составляющих образец }
{  TDataSample = array [1..NumValues] of Integer;
{  TDataString = array [0..20] of Char;     { Размер элемента как текста }
const
DataEntryName: PChar = 'DataEntry';
DataTopicName: PChar = 'SampledData';

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Data1: TMenuItem;
EnterData1: TMenuItem;
Clear1: TMenuItem;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure Exit1Click(Sender: TObject);

function MatchTopicAndService(Topic, Service: HSz): Boolean;
function MatchTopicAndItem(Topic, Item: HSz): Integer;
function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
function AcceptPoke(Item: HSz; ClipFmt: Word;
Data: HDDEData): Boolean;
function DataRequested(TransType: Word; ItemNum: Integer;
ClipFmt: Word): HDDEData;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure EnterData1Click(Sender: TObject);
procedure Clear1Click(Sender: TObject);

private
Inst       : Longint;
CallBack   : TCallback;
ServiceHSz : HSz;
TopicHSz   : HSz;
ItemHSz    : array [1..NumValues] of HSz;
ConvHdl    : HConv;
Advising   : array [1..NumValues] of Boolean;

DataSample : TDataSample;

public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses DDEDlg; { Форма DataEntry }

{$R *.DFM}

procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ Глобальная инициализация }

const
DemoTitle   : PChar = 'DDEML демо, серверное приложение';

MaxAdvisories = 100;
NumAdvLoops : Integer = 0;

{ Локальная функция: Процедура обратного вызова для DDEML }

{ Данная функция обратного вызова реагирует на все транзакции, генерируемые DDEML. Объект "target Window" (окно-цель) берется из глобально хранимых, и для реагирования на данную транзакцию, тип которой указан в параметре CallType, используются подходящие методы этих объектов.}
function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
var
ItemNum   : Integer;
begin
CallbackProc := 0;    { В противном случае смотрите доказательство }

case CallType of

xtyp_WildConnect:
CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);

xtyp_Connect:
if Conv = 0 then
begin
if Form1.MatchTopicAndService(HSz1, HSz2) then
CallbackProc := 1;   { Связь! }
end;
{ После подтверждения установки соединения записываем дескриптор связи как родительское окно.}
xtyp_Connect_Confirm:
Form1.ConvHdl := Conv;

{ Клиент запрашивает данные, делает прямой запрос или отвечает на уведомление. Возвращаем текущее состояние данных.}
xtyp_AdvReq, xtyp_Request:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
end;

{ Отвечаем на Poke-запрос ... данная демонстрация допускает только Pokes для DataItem1. Для подтверждения получения запроса возвращаем dde_FAck, в противном случае 0.}
xtyp_Poke:
begin
if Form1.AcceptPoke(HSz2, Fmt, Data) then
CallbackProc := dde_FAck;
end;

{ Клиент сделал запрос для старта цикла-уведомления. Имейте в виду, что мы организуем "горячий" цикл. Устанавливаем флаг Advising для указания открытого цикла, который будет проверять данные на предмет их изменения.}
xtyp_AdvStart:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then begin
if NumAdvLoops < MaxAdvisories then begin { Произвольное число }
Inc(NumAdvLoops);
Form1.Advising[ItemNum] := True;
CallbackProc := 1;
end;
end;
end;

{ Клиент сделал запрос на прерывание цикла-уведомления.}
xtyp_AdvStop:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
begin
if NumAdvLoops > 0 then
begin
Dec(NumAdvLoops);
if NumAdvLoops = 0 then
Form1.Advising[ItemNum] := False;
CallbackProc := 1;
end;
end;
end;
end;  { Case CallType }

end;

{ Возращает True, если данные Topic и Service поддерживаются этим приложением. В противном случае возвращается False.}

function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin
Result := False;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
if DdeCmpStringHandles(ServiceHSz, Service) = 0 then
Result := True;
end;

{ Определяем, один ли Topic и Item поддерживается этим приложением. Возвращаем номер заданного элемента (Item Number) (в пределах 1..NumValues), если он обнаружен, и ноль в противном случае.}

function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var
I : Integer;
begin
Result := 0;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
for I := 1 to NumValues do
if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
Result := I;
end;

{ Отвечаем на запрос wildcard-соединения (дословно - дикая карта, шаблон). Такие запросы возникают всякий раз, когда клиент пытается подключиться к серверу с сервисом или именем топика, установленного в 0. Если сервер обнаруживает использование такого рода шаблона, он возвращает дескриптор массива THSZPair, содержащего найденные по шаблону Service и Topic.}
 function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var
TempPairs: array [0..1] of THSZPair;
Matched  : Boolean;
begin
TempPairs[0].hszSvc  := ServiceHSz;
TempPairs[0].hszTopic:= TopicHSz;
TempPairs[1].hszSvc  := 0;     { 0-завершает список }
TempPairs[1].hszTopic:= 0;

Matched := False;

if (Topic= 0) and (Service = 0) then
Matched := True                    { Шаблон обработан, элементов не найдено }
else
if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then
Matched := True
else
if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then
Matched := True;

if Matched then
WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs),
0, 0, ClipFmt, 0)
else
WildConnect := 0;
end;

{ Принимаем и проталкиваем данные по просьбе клиента. Для демонстрации этого способа используем только значение DataItem1, изменяемое Poke.}

function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word;
Data: HDDEData): Boolean;
var
DataStr    : TDataString;
Err       : Integer;
TempSample: Integer;
begin
if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
(ClipFmt = cf_Text) then
begin
DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, TempSample, Err);

if IntToStr(TempSample) <> Label6.Caption then begin
Label6.Caption := IntToStr(TempSample);
DataSample[1] := TempSample;
if Advising[1] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
end;
AcceptPoke := True;
end
else
AcceptPoke := False;
end;

{ Возвращаем данные, запрашиваемые значениями TransType и ClipFmt. Такое может произойти в ответ на просьбу xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает на поддерживаемый (в диапазоне 1..NumValues) и требуемый элемент (обратите внимание на то, что данный метод подразумевает, что вызывающий оператор уже установил достоверность и ID требуемого пункта с помощью MatchTopicAndItem). Соответствующие данные из переменной экземпляра DataSample преобразуются в текст и возвращаются клиенту.}

function TForm1.DataRequested(TransType: Word; ItemNum: Integer;
ClipFmt: Word): HDDEData;
var ItemStr: TDataString;   { Определено в DataEntry.TPU }

begin
if ClipFmt = cf_Text then
begin
Str(DataSample[ItemNum], ItemStr);
DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
end
else
DataRequested := 0;
end;

{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный конструктор, затем устанавливаем эти объекты родителями экземпляров данных. }

procedure TForm1.FormCreate(Sender: TObject);
var I : Integer;
begin
Inst      := 0;      { Должен быть нулем для первого вызова DdeInitialize }
@CallBack := nil;    { MakeProcInstance вызывается из SetupWindow         }

for I := 1 to NumValues do begin
DataSample[I] := 0;
Advising[I]  := False;
end; { for }

end;

{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли создан экземпляр процедуры обратного вызова, если он существует. Также, для завершения диалога, вызовите DdeUninitialize. Затем, для завершения работы, вызовите разрушителя предка.}

procedure TForm1.FormDestroy(Sender: TObject);
var
I : Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);
for I := 1 to NumValues do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);

if Inst <> 0 then
DdeUninitialize(Inst);   { Игнорируем возвращаемое значение }

if @CallBack <> nil then
FreeProcInstance(@CallBack);
end;

procedure TForm1.FormShow(Sender: TObject);
var
I : Integer;
{ Завершаем инициализацию окна DDE сервера. Процедура инициализации использует DDEML для регистрации сервисов, предусмотренных данным приложением. Помните о том, что реальные имена, использованные в регистрах, определены в отдельном модуле (DataEntry), поэтому они могут быть использованы и клиентом. }
begin
@CallBack:= MakeProcInstance(@CallBackProc, HInstance);

if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz  := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
for I := 1 to NumValues do
ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
cp_WinAnsi);

if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
ShowMessage('Ошибка в процессе регистрации.');
end;
end;

procedure TForm1.EnterData1Click(Sender: TObject);
{ Активизируем диалог ввода данных и обновляем хранимые данные по окончании ввода.}
var
I: Integer;

begin
if DataEntry.ShowModal = mrOk then begin
with DataEntry do begin
Label6.Caption := S1;
Label7.Caption := S2;
Label8.Caption := S3;
DataSample[1] := StrToInt(S1);
DataSample[2] := StrToInt(S2);
DataSample[3] := StrToInt(S3);
end; { with }

for I := 1 to NumValues do
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end; { if }
end;

procedure TForm1.Clear1Click(Sender: TObject);
{ Очищаем текущую дату. }
var
I: Integer;

begin
for I := 1 to NumValues do begin
DataSample[I] := 0;
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end;

Label6.Caption := '0';
Label7.Caption := '0';
Label8.Caption := '0';
end;

end.
{ ***  КОНЕЦ КОДА DDESVRU.PAS *** }

{ *** НАЧАЛО КОДА DDEDLG.DFM *** }
 object DataEntry: TDataEntry
Left = 488
Top = 132
ActiveControl = OKBtn
BorderStyle = bsDialog
Caption = 'Ввод данных'
ClientHeight = 264
ClientWidth = 199
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
PixelsPerInch = 96
Position = poScreenCenter
OnShow = FormShow
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 8
Width = 177
Height = 201
Shape = bsFrame
IsControl = True
end
object OKBtn: TBitBtn
Left = 16
Top = 216
Width = 69
Height = 39
Caption = '&OK'
ModalResult = 1
TabOrder = 3
OnClick = OKBtnClick
Glyph.Data = {
BE060000424DBE06000000000000360400002800000024000000120000000100
0800000000008802000000000000000000000000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
A600000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
0303030303030303030303030303030303030303030303030303030303030303
03030303030303030303030303030303030303030303FF030303030303030303
03030303030303040403030303030303030303030303030303F8F8FF03030303
03030303030303030303040202040303030303030303030303030303F80303F8
FF030303030303030303030303040202020204030303030303030303030303F8
03030303F8FF0303030303030303030304020202020202040303030303030303
0303F8030303030303F8FF030303030303030304020202FA0202020204030303
0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
0303030303030303030303FA0202020403030303030303030303030303F8FF03
03F8FF03030303030303030303030303FA020202040303030303030303030303
0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
0202040303030303030303030303030303F8FF03F8FF03030303030303030303
03030303FA0202030303030303030303030303030303F8FFF803030303030303
030303030303030303FA0303030303030303030303030303030303F803030303
0303030303030303030303030303030303030303030303030303030303030303
0303}
Margin = 2
NumGlyphs = 2
Spacing = -1
IsControl = True
end
object CancelBtn: TBitBtn
Left = 108
Top = 216
Width = 69
Height = 39
Caption = '&Отмена'
TabOrder = 4
Kind = bkCancel
Margin = 2
Spacing = -1
IsControl = True
end
object Panel2: TPanel
Left = 16
Top = 88
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 1
object Label1: TLabel
Left = 24
Top = 8
Width = 5
Height = 13
end
object Label2: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 2:'
end
object Edit2: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel1: TPanel
Left = 16
Top = 16
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 0
object Label4: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 1:'
end
object Edit1: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel3: TPanel
Left = 16
Top = 144
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 2
object Label6: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 3:'
end
object Edit3: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
end
{ ***   КОНЕЦ КОДА DDEDLG.DFM *** }

{ *** НАЧАЛО КОДА DDEDLG.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Данный модуль определяет интерфейс сервера DataEntry DDE
(DDEMLSRV.PAS). Здесь определены имена Service, Topic,
и Item, поддерживаемые сервером, и также определена
структура данных, которая может использоваться
клиентом для локального хранения "показательных" данных.

Сервер Data Entry Server делает свои "показательные"
данные доступными в текстовом виде (cf_Text)
сформированными в виде трех различных топика (Topics).
Клиент может их преобразовывать в целое для
использования со структурой данных, которая здесь определена.
}
 unit Ddedlg;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, Mask, ExtCtrls;

type
TDataEntry = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
Bevel1: TBevel;
Panel2: TPanel;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
Label4: TLabel;
Panel3: TPanel;
Label6: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure OKBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
S1, S2, S3: String;
{ Public declarations }
end;

var
DataEntry: TDataEntry;

implementation

{$R *.DFM}

procedure TDataEntry.OKBtnClick(Sender: TObject);
begin
S1 := Edit1.Text;
S2 := Edit2.Text;
S3 := Edit3.Text;
end;

procedure TDataEntry.FormShow(Sender: TObject);
begin
Edit1.Text := '0';
Edit2.Text := '0';
Edit3.Text := '0';
Edit1.SetFocus;
end;

end.
{ ***  КОНЕЦ КОДА DDEDLG.PAS *** }

[001424]


Delphi 1

Как добавить группу в Program Manager?

interface procedure CreateGroup;

implementation

procedure TSetupForm.CreateGroup;
{ Для установки группы в Program Manager используем компонент TProgMan }
var
ItemList: TStringList;
GroupName: String;
ItemName: String;
i: word;
begin
{ Получаем из INI-файла строку GroupName }
GroupName := IniFile.ReadString('General', 'PMGroup', '');
{ Если один есть, устанавливаем группу }
if GroupName <> '' then begin
ItemList := TStringList.Create;
try
{ читаем элементы для установки }
IniFile.ReadSectionValues('PMGroup', ItemList);
with TProgMan.Create(Self) do
try
CreateGroup(GroupName);
for i := 0 to ItemList.Count - 1 do begin
{ получаем имя файла }ItemName := Copy(ItemList.Strings[i], 1, Pos('=',
ItemList.Strings[i]) - 1);
{ прибавляем путь к имени файла и добавляем элемент }
AddItem(GetTarget(ItemList.Values[ItemName][1]) + ItemName, ItemName);
end;
finally
Free;
end;
finally
ItemList.Free;
end;
end;
end;

[001426]


Delphi 1

OLE-автоматизация в Delphi 1

Delphi 16 также может осуществлять автоматизацию OLE, как она может и многое другое. Другое дело, что у нее нет компонентов-инкапсуляторов, и нет традиционных объектов, делающих работу с OLE такой же легкой, как это происходит с другими вещами в Delphi. Delphi32 таки должен иметь какие-то характеристики для работы с OLE (я так надеюсь).

Так, если вы собираетесь делать какие-то действия с любым типом OLE-сервера, то для этого вам необходимо будет использовать все нудные и противные рутинки из набора Windows SDK. Но будет лучше, если всем этим будет заправлять специализированный компонент. Но этот вопрос уже не к Borland. [001428]


Delphi 1

OLE сервер

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

unit Unit1;

interface
function OLEfunction(x, y, z: integer): integer; cdecl; export;
implementation

function OLEfunction(x, y, z: integer): integer;
begin
end;

procedure buildOLEstructure;
var
F: pointer;
begin
F := @OLEfunction; { Компилируется без проблем ... }
end;

end.

Используйте метод, приведенный ниже. Вы должны объявить одну вызывающую функцию к каждой комбинации параметров, которые вы собираетесь передавать. Затем вы вызываете вызывающую функцию (сорри) и передаете ей как указатель функцию, которую вы хотите вызвать (еще раз сорри). Непонятно? Поясню на примере:

library Pcdecl;

function olefunction(a1 : pchar; a2 : longint; x : integer )  : integer;
cdecl; export;
begin
end;

function callolefunction(func : pointer; a1 : pchar; a2 : longint; x :
integer)  : integer;
assembler;
asm
push        x             { помещаем параметры в обратном порядке }
push        word ptr a2 + 2     { если 32-битная величина передается в этих двух шагах, то начинаем с самой "высокой" (high) части }
push        word ptr a2
push        word ptr a1 + 2
push        word ptr a1
call        func
add        sp, 10                    { восстанавливаем стек добавлением вытолкнутых байтов. Обратите внимание на то, что func не была вытолкнута }
end;

procedure buildolefunction;
var
f         : pointer;
reslt     : integer;
begin
f := @olefunction;
{ --- }
reslt := callolefunction(f, 'Здравствуй, мир', 1000000, 25);
{ --- }
end;

begin
{ --- }
end.

На моем компьютере это компилируется без проблем. Должно работать и у вас. Предупреждение. Обращение к методам должно быть немного другим, нежели к функциям. [001430]


Как я могу избавиться от 'зарегистрированного' имени сервера, если я не хочу использовать его далее?

Nomadic советует:

Запустите исполняемый файл сервера с ключом /UNREGSERVER:

MYSERVER.EXE /UNREGSERVER
Это обычный путь разрегистрации саморегистрирующегося сервера автоматизации OLE. [001433]


Совместимость D1/D2

Какая может быть причина того, что программа, работающая в среде W31, не работает в W95 ?

Похоже на то, что данные, сохраненные в двоичном файле, читаются неправильно.

Имеется масса отличий в фундаментальных типах между Delphi 1.0 и Delphi 2.0, которые могут повлиять на двоичный файл. Вот некоторые из них:

  1. строки в Delphi 1.0 не эквивалентны строкам по умолчанию (длинным) в версии 2.0
  2. "integer" 16-биный в Delphi 1.0 и 32-битный в 2.0
  3. записи автоматически упаковываются в Delphi 1.0, но не в Delphi 2.0
- Rick Rogers [001111]


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

Куда из Delphi 3 делся модуль для работы с ReportSmith? А мои любимые модули работы с OLE: ole2, oleauto и olectl?

Nomadic отвечает:

Они лежат в X:\DELPHI3\LIB\DELPHI2. [001496]


Delphi 1

Ошибка маски редактирования на быстрых пентиумах

Данное поведение уже упоминалось ранее. Это, похоже, происходит только на быстрых машинах. Если у вас имеется исходный код RTL, вы можете сделать следующие изменения:

В MASK.PAS, замените

for I := Low(NewKeyState) to High(NewKeyState) do
NewKeyState[I] := 0;

На

NewKeyState := KeyState;

- Steve Schafer [001003]


Delphi 1

PASDBK16.DLL вызывает GPF

Кто-нибудь может мне сказать, почему я получаю эту ошибку, да еще с рекомендацией завершить работу Delphi? При попытке запустить мое приложение в среде ID, я получаю сообщение "PASDBK16.DLL caused a GPF at 0002:21e6 Shutdown of delphi is recommended" (PASDBK16.DLL вызвало GPF по адресу 0002:21e6. Рекомендуется завершить работу Delphi). Если я завершаю работу Delphi, снова его запускаю и пытаюсь после этого выполнить приложение, то получаю ошибку "Application is already running terminate before compiling" (Работа приложения уже прервана перед компиляцией).

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

- Sjef van der Velde [001103]


Delphi 1

Ошибка переполнения диска

Попробуйте удалить из вашего проекта все, кроме dpr, pas и dfm-файлов, и перекомпилить его. Похоже, один из файлов вашего проекта был испорчен. У меня была аналогичная проблема, и я смог ее решить только таким способом. [001439]


Ошибка чтения потока

Каждый раз при запуске Delphi 2.01 я получаю ошику "Stream Read Error" (ошибка чтения потока). Как мне отделаться от этого?

Удалите DSK- и DSM- файлы из вашего проектного каталога.

- Ralph Friedman [001093]


Некорректность реализации свойства BorderWidth

При использовании в компонентах свойства BorderWidth будте внимательны. В большинстве компонентов (ControlBar, ProgressBar, StatusBar, ToolBar, TrackBar и т.д.), это свойство реализовано некорректно. Можно получить забавные результаты или большие неприятности.

На рисунке показаны возможные варианты при использовании различных значений BorderWidth в компоненте ProgressBar. Высота компонента ProgressBar.Height = 16.

В последних двух вариантах вместо индикатора – изображение под активным окном. Не надейтесь, что компонент стал "прозрачным". Это "моментальный снимок" при создании окна.

Если есть желание, то некорректность можно исправить в ComCtrls.pas, переопределив BorderWidth.

…

TProgressBar = class(TWinControl)
private
…
FBorderWidth: TBorderWidth;
…
procedure SetBorderWidth(Value: TBorderWidth);
…
published
…
property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth;

…

constructor TProgressBar.Create(AOwner: TComponent);
begin
…
FBorderWidth := inherited BorderWidth;
…
end;

procedure TProgressBar.SetBorderWidth(Value: TBorderWidth);
begin
if Value > (Height div 2)-3 then Exit
if Value <> inherited BorderWidth then begin
inherited BorderWidth := Value;
FBorderWidth := inherited BorderWidth;
end;
end;

Аналогичный подход можно использовать в других компонентах. В процедуре SetBorderWidth вместо Exit можно создать исключение, но это уже на любителя. C уважением, VS. [001297]


Delphi 1

Обработка исключительных ситуаций

Попробуйте эту схему. У меня это работает.

procedure part_of_starting_up(n:string....)
var f: typed file;
begin
try
try
assign/reset(f,n);
while not eof(f) do
read_and_process_each_record(f);
finally
{$i-}     { Нет необходимости жаловаться, если закрытие прошло неудачно. }
close(f);
{$i+}
end;
except
on E:EInOutError do
case e.ErrorCode of
nn1: messagedlg('невозможно найти/открыть файл');
nn2: messagedlt('ошибка чтения файла');
end;
end
(и т.д.)

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

К сожалению (или к счастью), вы не можете вкладыть except & finally в блоки try.
[001668]


Delphi 1

Как обработать ошибку предже, чем программа уведомит об этом пользователя?

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

Приблизительно так:

Объявите следующую процедуру в объекте вашей главной формы:

procedure MyException(Sender:TObject; E:Exception);

Затем делайте так:

procedure TMyForm.MyException(Sender:TObject; E:Exception);
begin
if (E.ClassType.ClassName='EConvertError') then
begin
{как-то общаемся с пользователем по-поводу ошибки}
end
else Application.ShowException(E); {позволяем Delphi показать ошибку}
end;

Наконец, позвольте приложению воспользоваться вашим новым обработчиком исключений:

procedure TMyForm.FormCreate(Sender: TObject);
begin
Application.OnException := MyException;
end;

[001670]


Delphi 1

Ошибки времени выполнения

type
str31  = string[31];

function ErrMeaning (ResultCode: Integer): str31;
{----------------------------------------------------------}
{ Возвращает строковое значение по коду ошибки.            }
{----------------------------------------------------------}
const
NumOfEntries = 108;
type
ErrorEntry = record
Code: Integer;
Meaning: str31;
end;
ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry;
const
MeaningsArray: ErrorMeaningsArray =
{Ошибки DOS}
((Code:   1;  Meaning: 'Неверный номер DOS-функции' {Invalid DOS function number}),
(Code:   2;  Meaning: 'Файл не найден' {File not found}),
(Code:   3;  Meaning: 'Путь не найден' {Path not found}),
(Code:   4;  Meaning: 'Слишком много открытых файлов' {Too many open files}),
(Code:   5;  Meaning: 'В доступе к файлу отказано' {File access denied}),
(Code:   6;  Meaning: 'Неверный дескриптор файла' {Invalid file handle}),
(Code:   7;  Meaning: 'Разрушены управляющие блоки памяти' {Memory control blocks destroyed}),
(Code:   8;  Meaning: 'Недостаточно памяти DOS' {Insufficient DOS memory}),
(Code:   9;  Meaning: 'Неверный адрес блока памяти' {Invalid memory block address}),
(Code:  10;  Meaning: 'Неверное окружение DOS' {Invalid DOS environment}),
(Code:  11;  Meaning: 'Неверный формат (DOS)' {Invalid format (DOS)}),
(Code:  12;  Meaning: 'Неверный код доступа к файлу' {Invalid file access code}),
(Code:  13;  Meaning: 'Неверные данные (DOS)' {Invalid data (DOS)}),
(Code:  15;  Meaning: 'Неверный номер устройства' {Invalid drive number}),
(Code:  16;  Meaning: 'Невозможно удалить текущую директорию' {Cannot remove current directory}),
(Code:  17;  Meaning: 'Невозможно переименовать драйвер' {Cannot rename across drives}),
(Code:  18;  Meaning: 'Файлов больше нет' {No more files}),
(Code:  19;  Meaning: 'Диск защищен от записи' {Disk write-protected}),
(Code:  20;  Meaning: 'Неизвестное устройство (DOS)' {Unknown unit (DOS)}),
(Code:  21;  Meaning: 'Устройство не готово' {Drive not ready}),
(Code:  22;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}),
(Code:  23;  Meaning: 'CRC-ошибка' {CRC error}),
(Code:  24;  Meaning: 'Плохой запрос длины структуры' {Bad request structure length}),
(Code:  25;  Meaning: 'Ошибка поиска' {Seek error}),
(Code:  26;  Meaning: 'Неизвестный тип носителя' {Unknown media type}),
(Code:  27;  Meaning: 'Сектор диска не найден' {Disk sector not found}),
(Code:  28;  Meaning: 'Недостаточно бумаги' {Out of paper}),
(Code:  29;  Meaning: 'Ошибка записи' {Write fault}),
(Code:  30;  Meaning: 'Ошибка чтения' {Read fault}),
(Code:  31;  Meaning: 'Общий сбой' {General failure}),
(Code:  32;  Meaning: 'Нарушение общего доступа к файлу' {File sharing violation}),
(Code:  33;  Meaning: 'Нарушение блокировки файла' {File lock violation}),
(Code:  34;  Meaning: 'Неверная смена диска' {Invalid disk change}),
(Code:  35;  Meaning: 'Управляющий блок файла недоступен' {File control block unavailable}),
(Code:  36;  Meaning: 'Переполнение разделяемого буфера' {Sharing buffer overflow}),
(Code:  37;  Meaning: 'Несовпадение кодовой страницы' {Code page mismatch}),
(Code:  38;  Meaning: 'Ошибка обработки EOF' {Error handling EOF}),
(Code:  39;  Meaning: 'Дескриптор диска полон' {Handle disk full}),
(Code:  50;  Meaning: 'Сетевой запрос не поддерживается' {Network request not supported}),
(Code:  51;  Meaning: 'Удаленный компьютер недоступен' {Remote computer not listening}),
(Code:  52;  Meaning: 'Дубликат имени в сети' {Duplicate name on network}),
(Code:  53;  Meaning: 'Сетевое имя не найдено' {Network name not found}),
(Code:  54;  Meaning: 'Сеть занята' {Network busy}),
(Code:  55;  Meaning: 'Сетевое устройство больше не существует' {Network device no longer exists}),
(Code:  56;  Meaning: 'Превышен лимит команды NetBIOS' {NetBIOS command limit exceeded}),
(Code:  57;  Meaning: 'Ошибка сетевого адаптера' {Network adaptor error}),
(Code:  58;  Meaning: 'Неверный сетевой ответ' {Incorrect network response}),
(Code:  59;  Meaning: 'Неожиданная ошибка сети' {Unexpected network error}),
(Code:  60;  Meaning: 'Несовместимый удаленный адаптер' {Incompatible remote adaptor}),
(Code:  61;  Meaning: 'Очередь на печать переполнена' {Print queue full}),
(Code:  62;  Meaning: 'Нет достаточного места для файла печати' {Not enough space for print file}),
(Code:  63;  Meaning: 'Файл печати удален' {Print file deleted}),
(Code:  64;  Meaning: 'Сетевое имя удалено' {Network name deleted}),
(Code:  65;  Meaning: 'Доступ запрещен' {Access denied}),
(Code:  66;  Meaning: 'Неверный тип сетевого устройства' {Network device type incorrect}),
(Code:  67;  Meaning: 'Сетевое имя не найдено' {Network name not found}),
(Code:  68;  Meaning: 'Превышен предел сетевого имени' {Network name limit exceeded}),
(Code:  69;  Meaning: 'Превышен предел сеансов NetBIOS' {NetBIOS session limit exceeded}),
(Code:  70;  Meaning: 'Временная пауза' {Temporarily paused}),
(Code:  71;  Meaning: 'Сетевой запрос не принят' {Network request not accepted}),
(Code:  72;  Meaning: 'Пауза переадресации печати/диска' {Print/disk redirection paused}),
(Code:  80;  Meaning: 'Файл уже существует' {File already exists}),
(Code:  82;  Meaning: 'Невозможно создать каталог' {Cannot make directory entry}),
(Code:  83;  Meaning: 'Ошибка прерывания 24' {Fail on interrupt 24}),
(Code:  84;  Meaning: 'Слишком много переадресаций' {Too many redirections}),
(Code:  85;  Meaning: 'Дубликат переадресации' {Duplicate redirection}),
(Code:  86;  Meaning: 'Неверный пароль' {Invalid password}),
(Code:  87;  Meaning: 'Неверный параметр' {Invalid parameter}),
(Code:  88;  Meaning: 'Ошибка данных сети' {Network data fault}),
{Ошибки ввода/вывода (I/O errors)}
(Code: 100;  Meaning: 'Ошибка чтения диска' {Disk read error}),
(Code: 101;  Meaning: 'Ошибка записи диска' {Disk write error}),
(Code: 102;  Meaning: 'Файл не назначен' {File not assigned}),
(Code: 103;  Meaning: 'Файл не открыт' {File not open}),
(Code: 104;  Meaning: 'Не открыт файл для приема' {File not open for input}),
(Code: 105;  Meaning: 'Не открыт файл для выдачи' {File not open for output}),
(Code: 106;  Meaning: 'Неверный числовой формат' {Invalid numeric format}),
{Критические ошибки (Только для реального или защищенного режима)}
(Code: 150;  Meaning: 'Диск защищен от записи' {Disk is write protected}),
(Code: 151;  Meaning: 'Неизвестное устройство' {Unknown unit}),
(Code: 152;  Meaning: 'Устройство не готово' {Drive not ready}),
(Code: 153;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}),
(Code: 154;  Meaning: 'Ошибка CRC в данных' {CRC error in data}),
(Code: 155;  Meaning: 'Плохой запрос длины структуры устройства' {Bad drive request struct length}),
(Code: 156;  Meaning: 'Ошибка позиционирования диска' {Disk seek error}),
(Code: 157;  Meaning: 'Неизвестный тип носителя' {Unknown media type}),
(Code: 158;  Meaning: 'Сектор не найден' {Sector not found}),
(Code: 159;  Meaning: 'Недостаточно бумаги в принтере' {Printer out of paper}),
(Code: 160;  Meaning: 'Ошибка записи устройства' {Device write fault}),
(Code: 161;  Meaning: 'Ошибка чтения устройства' {Device read fault}),
(Code: 162;  Meaning: 'Аппаратный сбой' {Hardware failure}),
{Фатальные ошибки}
(Code: 200;  Meaning: 'Деление на ноль' {Division by zero}),
(Code: 201;  Meaning: 'Ошибка проверки диапазона' {Range check error}),
(Code: 202;  Meaning: 'Ошибка переполнения стека' {Stack overflow error}),
(Code: 203;  Meaning: 'Ошибка переполнения кучи' {Heap overflow error}),
(Code: 204;  Meaning: 'Неверная операция с указателем' {Invalid pointer operation}),
(Code: 205;  Meaning: 'Переполнение числа с плавающей точкой' {Floating point overflow}),
(Code: 206;  Meaning: 'Потеря значимости числа с плавающей точкой' {Floating point underflow}),
(Code: 207;  Meaning: 'Неверная операция с числом с плавающей точкой' {Invalid floating pt. operation}),
(Code: 208;  Meaning: 'Не установлен оверлей-менеджер' {Overlay manager not installed}),
(Code: 209;  Meaning: 'Ошибка чтения оверлей-файла' {Overlay file read error}),
(Code: 210;  Meaning: 'Объект не инициализирован' {Object not initialised}),
(Code: 211;  Meaning: 'Вызов абстрактного метода' {Call to abstract method}),
(Code: 212;  Meaning: 'Ошибка регистрации потока' {Stream registration error}),
(Code: 213;  Meaning: 'Индекс TCollection вышел за границы диапазона' {TCollection index out of range}),
(Code: 214;  Meaning: 'Ошибка переполнения TCollection' {TCollection overflow error}),
(Code: 215;  Meaning: 'Ошибка арифметического переполнения' {Arithmetic overflow error}),
(Code: 216;  Meaning: 'Общая ошибка защиты' {General Protection Fault}),
(Code: 217;  Meaning: 'Необработанное исключение' {Unhandled exception}),
(Code: 219;  Meaning: 'Неверное приведение типа' {Invalid typecast}));
var
Low, High, Mid, Diff: Integer;
begin
Low := 1;
High := NumOfEntries;
while Low <= High do
begin
Mid := (Low + High) div 2;
Diff := MeaningsArray[Mid].Code - ResultCode;
if Diff < 0 then Low  := Mid + 1 else
if Diff > 0 then High := Mid - 1 else
begin {нашли это}
ErrMeaning := MeaningsArray[Mid].Meaning;
Exit; {ErrMeaning}
end;
end; {while}
ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) +
' (неизвестное значение)';
end; {ErrMeaning}

...я привожу несколько. Они все взяты из 'Delphi Developers Guide' (руководство Delphi-разработчика) авторов Pacheco и Teixeira.
>  type
>    str31 = string[31];
>
>  function ErrMeaning (ResultCode: Integer): str31;
> {----------------------------------------------------------------}
> { Возвращает строковое значение по коду ошибки.                  }
> {----------------------------------------------------------------}
>  const
>    NumOfEntries = 48;
>  type
>    ErrorEntry = record
>      Code: Integer;
>      Meaning: str31;
>    end;
>    ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry;
>  const
>    MeaningsArray: ErrorMeaningsArray =
> {DOS errors}
>   ((Code:   1;  Meaning: 'Неправильный номер функции DOS' {Invalid DOS function number}),
>    (Code:   2;  Meaning: 'Файл не найден' {File not found}),
>    (Code:   3;  Meaning: 'Путь не найден' {Path not found}),
>    (Code:   4;  Meaning: 'Слишком много открытых файлов' {Too many open files}),
>    (Code:   5;  Meaning: 'Доступ к файлу запрещен' {File access denied}),
>    (Code:   6;  Meaning: 'Неверный дескриптор файла' {Invalid file handle}),
7 Разрушены управляющие блоки памяти (Memory Control Blocks Destroyed)
8 Недостаточно памяти (Insufficient memory (NFI))
9 Неверный адрес блока памяти (Invalid Memory Block Address)
10 Неверная среда (Invalid Environment)
11 Неверный формат (Invalid format)
>    (Code:  12;  Meaning: 'Неверный код доступа к файлу' {Invalid file access code}),
13 Неверные данные {Invalid Data}
14 Зарезервировано {Reserved}

>    (Code:  15;  Meaning: 'Неверный номер устройства' {Invalid drive number}),
>    (Code:  16;  Meaning: 'Невозможно удалить текущую директорию' {Cannot remove current directory}),
>    (Code:  17;  Meaning: 'Невозможно переименовать драйвер' {Cannot rename across drives}),
>    (Code:  18;  Meaning: 'файлов больше нет' {No more files}),

19 Диск защищен от записи {Disk write protected}
20 Неизвестное устройство {Unknown unit}
21 Устройство не готово {Drive not ready}
22 Неизвестная команда {Unknown command}
23 Ошибка CRC {CRC error}
24 Плохой запрос длины структуры {Bad request Structure Length}
25 Ошибка поиска {Seek Error}
26 Неизвестный тип носителя {Unknown media type}
27 Сектор не найден {Sector not found}
28 Недостаточно бумаги {Out of paper}
29 Ошибка записи {Write fault}
30 Ошибка чтения {Read Fault}
31 Общий сбой {General Failure}
32 Нарушение общего доступа {Sharing violation}
33 Нарушение блокировки {Lock violation}
34 Неверная смена диска {Invalid Disk Change}
35 FCB недоступно {FCB unavailable}
36 Переполнение буфера общего доступа {Sharing buffer overflow}
37 Несовпадение кодовой страницы {Code page mismatch}
38 Ошибка обработки EOF (конца файла) {Error handling EOF}
39 Обработка переполнения диска ?? {Handle disk full ??}
40..49 Зарезервировано {Reserved}

(Code :50 ; Meaning : 'Сетевой запрос не поддерживается' {Network request not supported}),
(Code :51 ; Meaning : 'Удаленный компьютер недоступен' {Remote computer not listening}),
(Code :52 ; Meaning : 'Дубликат имени в сети' {Duplicate name on network}),
(Code :53 ; Meaning : 'Сетевое имя не найдено' {Network name not found}),
(Code :54 ; Meaning : 'Сеть занята' {Network busy}),
(Code :55 ; Meaning : 'Сетевое устройство больше не существует' {Network device no longer exists}),
(Code :56 ; Meaning : 'Превышен лимит команды NetBIOS' {NETBIOS command limit exceeded}),
(Code :57 ; Meaning : 'Ошибка сетевого адаптера' {Network adapter error}),
(Code :58 ; Meaning : 'Неверный сетевой ответ' {Incorrect network response}),
(Code :59 ; Meaning : 'Неожиданная ошибка сети' {Unexpected network error}),
(Code :60 ; Meaning : 'Несовместимый сетевой адаптер' {Incompatible remote adapter}),
(Code :61 ; Meaning : 'Очередь на печать переполнена' {Print queue full}),
(Code :62 ; Meaning : 'Нет достаточного места для файла печати' {Not enough space for print file}),
(Code :63 ; Meaning : 'Файл печати удален' {Print file deleted}),
(Code :64 ; Meaning : 'Сетевое имя удалено' {Network name deleted}),
(Code :65 ; Meaning : 'Доступ запрещен' {Access denied}),
(Code :66 ; Meaning : 'Неверный тип сетевого устройства' {Network device type incorrect}),
(Code :67 ; Meaning : 'Сетевое имя не найдено' {Network name not found}),
(Code :68 ; Meaning : 'Превышен предел сетевого имени' {Network name limit exceeded}),
(Code :69 ; Meaning : 'Превышен предел сеансов NETBIOS' {NETBIOS session limit exceeded}),
(Code :70 ; Meaning : 'Временная пауза' {Temporarily paused}),
(Code :71 ; Meaning : 'Сетевой запрос не принят' {Network request not accepted}),
(Code :72 ; Meaning : 'Печать или дисковая переадресация приостановлена' {Print or disk redirection is paused}),
(Code :73..79; Meaning : 'Зарезервировано' {Reserved}),
(Code :80 ; Meaning : 'Файл уже существует' {File already exists}),
(Code :81 ; Meaning : 'Зарезервировано' {Reserved}),
(Code :82 ; Meaning : 'Невозможно создать каталог' {Cannot make directory entry}),
(Code :83 ; Meaning : 'Ошибка прерывания 24' {Fail on Interrupt 24}),
(Code :84 ; Meaning : 'Cлишком много переадресаций' {Too many redirections}),
(Code :85 ; Meaning : 'Дубликат переадресации' {Duplicate redirection}),
(Code :86 ; Meaning : 'Неверный пароль' {Invalid password}),
(Code :87 ; Meaning : 'Неверный параметр {Invalid parameter}),
(Code :88 ; Meaning : 'Ошибка данных сети' {Network data fault}),

>{Ошибки ввода/вывода (I/O errors)}
>    (Code: 100;  Meaning: 'Ошибка чтения диска' {Disk read error}),
>    (Code: 101;  Meaning: 'Ошибка записи диска' {Disk write error}),
>    (Code: 102;  Meaning: 'Файл не назначен' {File not assigned}),
>    (Code: 103;  Meaning: 'Файл не открыт' {File not open}),
>    (Code: 104;  Meaning: 'Не открыт файл для приема' {File not open for input}),
>    (Code: 105;  Meaning: 'Не открыт файл для выдачи' {File not open for output}),
>    (Code: 106;  Meaning: 'Неверный числовой формат' {Invalid numeric format}),
>{Критические ошибки (Только для реального или защищенного режима)} ({Critical errors (Real or proteted mode only)})
>    (Code: 150;  Meaning: 'Диск защищен от записи' {Disk is write protected}),
>    (Code: 151;  Meaning: 'Неизвестное устройство' {Unknown unit}),
>    (Code: 152;  Meaning: 'Устройство не готово' {Drive not ready}),
>    (Code: 153;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}),
>    (Code: 154;  Meaning: 'Ошибка CRC в данных' {CRC error in data}),
>    (Code: 155;  Meaning: 'Плохой запрос длины структуры устройства' {Bad drive request struct length}),
>    (Code: 156;  Meaning: 'Ошибка позиционирования диска' {Disk seek error}),
>    (Code: 157;  Meaning: 'Неизвестный тип носителя' {Unknown media type}),
>    (Code: 158;  Meaning: 'Сектор не найден' {Sector not found}),
>    (Code: 159;  Meaning: 'Недостаточно бумаги в принтере' {Printer out of paper}),
>    (Code: 160;  Meaning: 'Ошибка записи устройства' {Device write fault}),
>    (Code: 161;  Meaning: 'Ошибка чтения устройства' {Device read fault}),
>    (Code: 162;  Meaning: 'Аппаратный сбой' {Hardware failure}),
> {Фатальные ошибки (Fatal errors)}
>    (Code: 200;  Meaning: 'Деление на ноль' {Division by zero}),
>    (Code: 201;  Meaning: 'Ошибка проверки диапазона' {Range check error}),
>    (Code: 202;  Meaning: 'Ошибка переполнения стека' {Stack overflow error}),
>    (Code: 203;  Meaning: 'Ошибка переполнения кучи' {Heap overflow error}),
>    (Code: 204;  Meaning: 'Неверная операция с указателем' {Invalid pointer operation}),
>    (Code: 205;  Meaning: 'Переполнение числа с плавающей точкой' {Floating point overflow}),
>    (Code: 206;  Meaning: 'Потеря значимости числа с плавающей точкой' {Floating point underflow}),
>    (Code: 207;  Meaning: 'Неверная операция с числом с плавающей точкой' {Invalid floating pt. operation}),
>    (Code: 208;  Meaning: 'Не установлен оверлей-менеджер' {Overlay manager not installed}),
>    (Code: 209;  Meaning: 'Ошибка чтения оверлей-файла' {Overlay file read error}),
>    (Code: 210;  Meaning: 'Объект не инициализирован' {Object not initialised}),
>    (Code: 211;  Meaning: 'Вызов абстрактного метода' {Call to abstract method}),
>    (Code: 212;  Meaning: 'Ошибка регистрации потока' {Stream registration error}),
>    (Code: 213;  Meaning: 'Индекс TCollection вышел за границы диапазона' {TCollection index out of range}),
>    (Code: 214;  Meaning: 'Ошибка переполнения TCollection' {TCollection overflow error}),
>    (Code: 215;  Meaning: 'Ошибка арифметического переполнения' {Arithmetic overflow error}),
>    (Code: 216;  Meaning: 'Общая ошибка защиты' {General Protection Fault}));

217 Необработанное исключение (Unhandled Exception)
219 Неверное приведение типа (Invalid typecast)

>  var
>    i: Integer;
>  begin
>    for i := 1 to NumOfEntries do
>      if MeaningsArray[i].Code < ResultCode then
>        Continue {до следующей итерации цикла FOR loop}
>      else
>      begin
>        if MeaningsArray[i].Code = ResultCode then
>        begin
>          ErrMeaning := MeaningsArray[i].Meaning;
>          Exit; {ErrMeaning}
>        end
>        else {Code in array > ResultCode}
>          Break; {выход из цикла FOR}
>      end;
>    ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) +
>                  ' (неизвестное значение)';
>  end; {ErrMeaning}
[001797]


Совет читателя

Как получить текстовое описание ошибки, полученной GetLastError?

Своим опытом делится Олег Кулабухов:

Используйте SysErrorMessage.

procedure TForm1.Button1Click(Sender: TObject);
begin
{Cause a Windows system error message to be logged}
ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;

[001857]


Delphi 2

Вызов Delphi DLL из MS Visual C++ II

Во-первых, создайте в Delphi простую DLL:

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

Library MinMax;

Function Min(X, Y: Integer): Integer; export;
begin
if X < Y then Min := X else Min := Y;
end;

Function Max(X, Y: Integer): Integer; export;
begin
if X > Y then Max := X else Max := Y;
end;

Exports
Min index 1,
Max index 2;

begin
end.

{ Конец кода DLL }

Затем, для вызова этих функций из вашего C кода, сделайте следующее:

  1. В вашем .DEF-файле добавьте следующие строки:

    IMPORTS
    Min  =MINMAX.Min
    Max  =MINMAX.Max

  2. Объявите в вашем C-приложени прототип функций, как показано ниже:
        int FAR PASCAL Min(int x, y);
    int FAR PASCAL Min(int x, y);
  3. Теперь из любого места вашего приложения вы можете вызвать функции Min и Max.
[001648]


Delphi 1

Проблема использования в DLL чисел с плавающей точкой

...если вы DLL создаете не с помощью Delphi, то не делайте так, чтобы возвращаемое функцией значение имело тип числа с плавающей точкой. Вместо этого для возвращаемого значения используйте var-параметр (указатель или ссылочный параметр в C++).

Я допускаю, что ваша DLL компилируется в M$ VC++. Причина кроется в том, что Borland и M$ применяют различные способы возврата чисел с плавающей точкой. Borland C++ и Delphi могут использовать один и тот же метод (через стек математического сопроцессора), но я не уверен в этом.

Так, если вы работаете с процедурами вместо функций, которые должны возвращать OK.

BTW: не используйте одинарную или двойную точность. Они могут быть изменены компилятором. Используйте тип double. [001654]


Delphi 2

Синхронизация DLL с открытым набором данных

Тема: Синхронизация DLL с открытым набором данных

В данном совете показано как с помощью Object Pascal динамически, на лету, связать DLL с активной базой данных, таким образом дающей программисту возможность воспользоваться Modularize-характеристикой. (Независимо от текущего режима, будь то разработка приложения, или его выполнение)

Технология динамической линковки DLL к EXE полезна во многих случаях. Например, работа с пакетами для создания 'plug-in' модулей (A/R, A/P, General Ledger и др.) или Point of Sale package с Current Stock, FIFO/LIFO Ordering, Vendor Tracking, и пр. модули.

Данная статья дает работающий пример того, как это сделать с единственной dll, 'Editdll.dll', и предоставит разработчику материал, расказывающий о том, как организовать в вашем приложении подключаемые модули.

Предварительные условия:

Хорошее знание работы компонента TTable, умение использовать DLL, BDE API и знание BDE hCursor. *WIN API для динамической загрузки любых DLL.

Пример приложения

Приведенная ниже форма, EditForm, работает с таблицей COUNTRY, расположенной в каталоге DBDEMO. При нажатии пользователем кнопки 'Edit' или при двойном щелчке на записи (строке), возникает диалоговое окно, расположенное в 'EditDll.dll' и демонстрирующее специфическую информацию, относящуюся к данной записи. В этой "точке" DLL синхронизирует себя не только с набором данных (и сессией), но и с текущей записью. Это означает, что полозователь изменяет те же самые данные, что он видит в EditForm! Ну а теперь углубимся в код демонстрационного приложения. (Для удобства просто скопируйте отсюда эти файлы и вставьте в ваше приложение)

Проект главной формы

{ MAINDB.DPR }
program maindb;

uses
Forms,
mainform in 'mainform.pas' {DBMainForm};

{$R *.RES}

begin
Application.Initialize;
Application.CreateForm(TDBMainForm, DBMainForm);
Application.Run;
end.

{ MAINFORM.PAS }
unit mainform;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, Forms, DBCtrls, DB, DBGrids, DBTables, Grids, ExtCtrls, BDE;

type
TDBMainForm = class(TForm)
Table1Name: TStringField;
Table1Capital: TStringField;
Table1Continent: TStringField;
Table1Area: TFloatField;
Table1Population: TFloatField;
DBGrid1: TDBGrid;
DBNavigator: TDBNavigator;
Panel1: TPanel;
DataSource1: TDataSource;
Panel2: TPanel;
Table1: TTable;
EditButton: TButton;
procedure FormCreate(Sender: TObject);
procedure EditButtonClick(Sender: TObject);
procedure DBGrid1DblClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;

var
DBMainForm: TDBMainForm;

implementation

{$R *.DFM}

procedure TDBMainForm.FormCreate(Sender: TObject);
begin
Table1.Open;
end;

// {ПРИМЕЧАНИЕ: DBHandle - дескриптор базы данных & DSHandle - курсор
//  рассматриваемой записи. Кроме того, если вы имеете цель в
//  динамической загрузке DLL во время выполнения приложения,
//  используйте вызовы API LoadLibrary, GetProcAddress и
//  FreeLibrary вместо подразумевающихся вызовов загрузки при
//  запуске. Пример использования API для динамической загрузки: }
// Type
//  {Для GetProcAddress}
//  BDEDataSync =
//    function(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean;
//             stdcall;
//  {Организация перехвата ошибок загрузки DLL}
//  EDLLLoadError = class(Exception);
// var h: hwnd;
//     p: BDEDataSync;
//     LastError: DWord;
// begin
// UpdateCursorPos;
// Try
//   h := loadLibrary('EDITDLL.DLL');
//   {Примечание для пользователей Delphi 1.0: Поскольку Win32
//    LoadLibrary при неудачной загрузке DLL возвращает NULL,
//    поэтому для поиска ошибки необходим вызов GetLastError,
//    Win16 LoadLibrary возвращает значение ошибки (меньше чем
//    HINSTANCE_ERROR), которая для выяснения причин неудачной
//    загрузки может затем провериться с помощью Win16API SDK.}
//   if h = 0 then begin
//      LastError := GetLastError;
//      Raise EDLLLoadError.create(IntToStr(LastError) +
//                                 ': Невозможно загрузить DLL');
//      end;
//   try
//      p := getProcAddress(h, 'EditData');
//      if p(DBHandle, Handle) then Resync([]);
//   finally
//      freeLibrary(h);
//   end;
// Except
//   On E: EDLLLoadError do
//     MessageDLG(E.Message, mtInformation, [mbOk],0);
// end;
// end;
// {или}
function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur):
Boolean;  stdcall external 'EDITDLL.DLL' name 'EditData';

procedure TDBMainForm.EditButtonClick(Sender: TObject);
begin
with Table1 do
begin
UpdateCursorPos;
// Вызываем процедуру EditData из EditDll.dll.
if EditData(DBHandle, Handle) then Resync([]);
end;
end;

procedure TDBMainForm.DBGrid1DblClick(Sender: TObject);
begin
EditButton.Click;
end;

end.

Проект EDIT DLL

{ EDITDLL.DPR }
library editdll;

uses
SysUtils,
Classes,
editform in 'editform.pas' {DBEditForm};

exports
EditData;

begin
end.

{ EDITFORM.PAS }
unit editform;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, Forms, DBCtrls, DB, DBTables, Mask, ExtCtrls, BDE;

type
TTableClone = class;

TDBEditForm = class(TForm)
ScrollBox: TScrollBox;
Label1: TLabel;
EditName: TDBEdit;
Label2: TLabel;
EditCapital: TDBEdit;
Label3: TLabel;
EditContinent: TDBEdit;
Label4: TLabel;
EditArea: TDBEdit;
Label5: TLabel;
EditPopulation: TDBEdit;
DBNavigator: TDBNavigator;
Panel1: TPanel;
DataSource1: TDataSource;
Panel2: TPanel;
Database1: TDatabase;
OKButton: TButton;
private
TableClone: TTableClone;
end;

{ TTableClone }

TTableClone = class(TTable)
private
SrcHandle: HDBICur;
protected
function CreateHandle: HDBICur; override;
public
procedure OpenClone(ASrcHandle: HDBICur);
end;

function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean; stdcall;

var
DBEditForm: TDBEditForm;

implementation

{$R *.DFM}

{ Экспорт }

function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean; stdcall;
var
DBEditForm: TDBEditForm;
begin
DBEditForm := TDBEditForm.Create(Application);
with DBEditForm do
try
// Устанавливаем дескриптор Database1 на открытую в текущий момент базу данных
Database1.Handle := DBHandle;
TableClone := TTableClone.Create(DBEditForm);
try
TableClone.DatabaseName := 'DB1';
DataSource1.DataSet := TableClone;
TableClone.OpenClone(DSHandle);
Result := (ShowModal = mrOK);
if Result then
begin
TableClone.UpdateCursorPos;
DbiSetToCursor(DSHandle, TableClone.Handle);
end;
finally
TableClone.Free;
end;
finally
Free;
end;
end;

{ TTableClone }

procedure TTableClone.OpenClone(ASrcHandle: HDBICur);
begin
SrcHandle := ASrcHandle;
Open;
DbiSetToCursor(Handle, SrcHandle);
Resync([]);
end;

function TTableClone.CreateHandle: HDBICur;
begin
Check(DbiCloneCursor(SrcHandle, False, False, Result));
end;

end.

{ EDITFORM.DFM }
object DBEditForm: TDBEditForm
Left = 201
Top = 118
Width = 354
Height = 289
ActiveControl = Panel1
Caption = 'DBEditForm'
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 346
Height = 41
Align = alTop
TabOrder = 0
object DBNavigator: TDBNavigator
Left = 8
Top = 8
Width = 240
Height = 25
DataSource = DataSource1
Ctl3D = False
ParentCtl3D = False
TabOrder = 0
end
object OKButton: TButton
Left = 260
Top = 8
Width = 75
Height = 25
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
object Panel2: TPanel
Left = 0
Top = 41
Width = 346
Height = 221
Align = alClient
BevelInner = bvLowered
BorderWidth = 4
Caption = 'Panel2'
TabOrder = 1
object ScrollBox: TScrollBox
Left = 6
Top = 6
Width = 334
Height = 209
HorzScrollBar.Margin = 6
HorzScrollBar.Range = 147
VertScrollBar.Margin = 6
VertScrollBar.Range = 198
Align = alClient
AutoScroll = False
BorderStyle = bsNone
TabOrder = 0
object Label1: TLabel
Left = 6
Top = 6
Width = 28
Height = 13
Caption = 'Name'
FocusControl = EditName
end
object Label2: TLabel
Left = 6
Top = 44
Width = 32
Height = 13
Caption = 'Capital'
FocusControl = EditCapital
end
object Label3: TLabel
Left = 6
Top = 82
Width = 45
Height = 13
Caption = 'Continent'
FocusControl = EditContinent
end
object Label4: TLabel
Left = 6
Top = 120
Width = 22
Height = 13
Caption = 'Area'
FocusControl = EditArea
end
object Label5: TLabel
Left = 6
Top = 158
Width = 50
Height = 13
Caption = 'Population'
FocusControl = EditPopulation
end
object EditName: TDBEdit
Left = 6
Top = 21
Width = 135
Height = 21
DataField = 'Name'
DataSource = DataSource1
MaxLength = 0
TabOrder = 0
end
object EditCapital: TDBEdit
Left = 6
Top = 59
Width = 135
Height = 21
DataField = 'Capital'
DataSource = DataSource1
MaxLength = 0
TabOrder = 1
end
object EditContinent: TDBEdit
Left = 6
Top = 97
Width = 135
Height = 21
DataField = 'Continent'
DataSource = DataSource1
MaxLength = 0
TabOrder = 2
end
object EditArea: TDBEdit
Left = 6
Top = 135
Width = 65
Height = 21
DataField = 'Area'
DataSource = DataSource1
MaxLength = 0
TabOrder = 3
end
object EditPopulation: TDBEdit
Left = 6
Top = 173
Width = 65
Height = 21
DataField = 'Population'
DataSource = DataSource1
MaxLength = 0
TabOrder = 4
end
end
end
object DataSource1: TDataSource
Left = 95
Top = 177
end
object Database1: TDatabase
DatabaseName = 'DB1'
LoginPrompt = False
SessionName = 'Default'
Left = 128
Top = 176
end
end

[001033]


Как вызывать функцию 16-битной DLL из 32-битного приложения?

Из советов Nomadic'a:

Надо использовать Thunks.

Кусок работающего только под Windows 95 кода -

const
Gfsr_SystemResources = 0;
Gfsr_GdiResources = 1;
Gfsr_UserResources = 2;
var
hInst16: THandle;
GFSR: Pointer;
{ Undocumented Kernel32 calls. }
function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;
procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;
function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
{ QT_Thunk needs a stack frame. }
{$StackFrames On}
{ Thunking call to 16-bit USER.EXE. The ThunkTrash argument
allocates space on the stack for QT_Thunk. }
function NewGetFreeSystemResources(SysResource: Word): Word;
var
ThunkTrash: array[0..$20] of Word;
begin
{ Prevent the optimizer from getting rid of ThunkTrash. }
ThunkTrash[0] := hInst16;
hInst16 := LoadLibrary16('user.exe');
if hInst16 < 32 then
raise Exception.Create('Can''t load USER.EXE!');
{ Decrement the usage count. This doesn't really free the
library, since USER.EXE is always loaded. }
FreeLibrary16(hInst16);
{ Get the function pointer for the 16-bit function in USER.EXE. }
GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
if GFSR = nil then
raise Exception.Create('Can''t get address of GetFreeSystemResources!');
{ Thunk down to USER.EXE. }
asm
push SysResource { push arguments }
mov edx, GFSR { load 16-bit procedure pointer }
call QT_Thunk { call thunk }
mov Result, ax { save the result }
end;
end;

[001086]


Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?

Из советов Nomadic'a:

Вы должны определить в программе вызываемую снаружи функцию.

Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов), второй - HINSTANCE задачи, третий - остаток командной строки (LPCSTR, даже под NT), четвертый - не знаю ;).

Hапример -

int __stdcall __declspec(dllexport) Test
(
HWND hWnd,
HINSTANCE hInstance,
LPCSTR lpCmdLine,
DWORD dummy
)
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}
Исполняем таким образом -
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой "this is a command line".

На Паскале -

Function Test(
hWnd: Integer;
hInstance: Integer;
lpCmdLine: PChar;
dummy: Longint
): Integer; StdCall; export;
begin
Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
Result := 0;
end;

Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого вида:

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD dummy );
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD dummy );
......
и .def-файл пpимеpно такого вида:
EXPORTS
RunDll
RunDllA=RunDll
RunDllW
то rundll32 становится pазбоpчивой -- под NT вызывает UNICODE-веpсию. Под 95, pазумеется, ANSI. [001166]


Delphi 2

16-битные DLL и Delphi 2

Вы можете вызывать 16-битные dll из 32-битных программ (delphi 2.0 создает 32-битные программы). И программа может выполняться под win32s и win95, но не под winNT, посколько NT не позволяет делать вызовы 16-битного кода из 32-битного. Поэтому для полной совместимости и 16 -> 32-битного преобразования кода лучше всего воспользоваться утилитой PortTool, которая сканирует ваши исходные файлы и сообщает вам, какие части 16-битного кода должны быть изменены, чтобы они работали под win32. [001643]


Простой шаблон для Delhi DLL

Пример DLL

Без модулей

Во-первых, "скелет" DLL, которую вы хотели, сохраняете как DLLFRAME.DPR:

{---------------------DLLFRAME.DPR--------------------------}
library Dllframe;

uses WinTypes;

function  GetString : string ; export ;
begin
Result := 'Привет из DLL!' ;
end;

exports
GetString;

begin
end.
{-----------------------------------------------------------}

Теперь напишем вызывающую программу и сохраним ее как DLLCALL.DPR:

{---------------------DLLCALL.DPR---------------------------}
program Dllcall;

uses
Dialogs;

{$R *.RES}

function GetString : string ; far ; external 'DLLFRAME' ;

begin
MessageDlg( GetString, mtInformation, [ mbOK ], 0 ) ;
end.

С модулями

Код вызывающей программы, сохраните ее как DLLCALL.DPR:

{---------------------DLLCALL.DPR---------------------------}
program Dllcall;

uses
Dialogs;

{$R *.RES}

function GetString : string ; far ; external 'MyDLL' ;

begin
MessageDlg( GetString, mtInformation, [ mbOK ], 0 ) ;
end.
{-----------------------------------------------------------}

"скелет" DLL, которую вы хотели, сохраняете как DLLFRAME.DPR:

{---------------------DLLFRAME.DPR--------------------------}
library Dllframe;

uses DLLUnit;

exports
GetString;

begin
end.
{-----------------------------------------------------------}

Модуль, который мы сохраняем как dllunit.pas:

{---------------------dllunit.pas--------------------------}

unit DLLUnit;
interface

uses WinTypes;

function GetString: string; export;

implementation

function GetString: string;
begin
GetString := 'Привет из DLL!' ;
end ;

begin
end.

[001645]


Delphi 1

Пример обратного вызова DLL II

Вот как я осуществляю обратный вызов процедуры Delphi из C++ DLL:

В Delphi:

interface

var
callBackProc : TFarProc;

procedure delphiProc (const x: Pchar); export;
procedure setupDLL (p: pointer);

implementation

procedure setupDLL (p: Pointer);  external 'MYDLL';

procedure delphiProc (const x: Pchar); { это вызываемая процедура }
begin
...
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
...
callBackProc := makeProcInstance(@delphiProc, gInstance);
setupDLL (callBackProc);
...
end;

procedure TForm1.FormDestroy (Sender: TObject);
begin
...
freeProcInstance (callBackProc);
...
end;

В C++ DLL:

   static void CALLBACK (*saveProc)(char*);

   void FAR _export pascal setupDLL (void CALLBACK (*func)(char*))
   {
      saveProc = func;
   }
затем, для вызова процедуры Delphi из C++ DLL, используется:

(*saveProc)(msg); // где msg - char*

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

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

Если ваш DLL родом не из Delphi, убедитесь в том, что типы string/pchar согласованы в обоих модулях.

Синтаксис тот же. В главной программе вы просто добавляете ключевое слово EXPORT к каждой функции, которую вы хотите экспортировать, наподобие того, как вы делаете это в DLL. В конце .DPR-файла, перед ключевым словом BEGIN, которое определяет начало основной программы, добавьте секцию с именем EXPORTS, где вы должны перечислить подпрограммы, которые вы хотите сделать доступными для обратных вызовов. Не такой очевидный, но очень важный шаг, который вы должны сделать, это скомпилировать главую программу с выключенной опцией умных обратных вызовов (smart callbacks). Очень важно, чтобы методы в программе имели доступ к своим собственным данным.
[001647]


Delphi 2

Cards.DLL

Боюсь, что я не знаю как работают функции и все остальное, но я могу вам помочь и дать имена и порядковые номера функций из этой DLL:

        0               Card Display Technology
        5               CDTANIMATE
        4               CDTTERM
        3               CDTDRAWEXT
        2               CDTDRAW
        1               CDTINIT
Благодаря Heath Ian Hunnicutt (heathh@cco.caltech.edu) код CARDS.DLL был дизассемблирован, вследствие чего и появился расположенный ниже материал.
 cards.h

#include "crd.h"

/*
 *  cdtInit: Инициализация карточного модуля
 *
 *  pdxCard: получаем ширину карты
 *  pdyCard: получаем высоту карты
 *  returns: успешно или неудачно
 */
BOOL FAR PASCAL cdtInit(int FAR *pdxCard, int FAR *pdyCard);

/*
 *  cdtDrawExt: Рисуем карту с заданными размерами
 *
 *  x, y:    координаты для отрисовки карты
 *  dx,dy:   размер для отрисовки
 *  cd:      карта для отрисовки
 *  mode:    способ передачи
 *  returns: успешно или неудачно
 */
BOOL FAR PASCAL cdtDrawExt(HDC hdc, int x, int y, int dx, int dy,=20
                    int cd, int mode, DWORD rgbBgnd);

/*
 *  cdtDraw: Отрисовка карты
 *
 *  x, y:    координаты для отрисовки карты
 *  cd:      карта для отрисовки
 *  mode:    способ передачи
 *  returns: успешно или неудачно
 */
BOOL FAR PASCAL cdtDraw(HDC hdc, int x, int y, int cd, int mode,
                   DWORD rgbBgnd);

/*
 *  cdtTerm: завершает и очищает карточный модуль

 */
void FAR PASCAL cdtTerm();

 cdt.h

#define CLOADMAX 5

/* Идентификаторы (ID) команд */
#define IDACLUBS	 1
#define ID2CLUBS	 2
#define ID3CLUBS	 3
#define ID4CLUBS	 4
#define ID5CLUBS	 5
#define ID6CLUBS	 6
#define ID7CLUBS	 7
#define ID8CLUBS	 8
#define ID9CLUBS	 9
#define IDTCLUBS	 10
#define IDJCLUBS	 11
#define IDQCLUBS	 12
#define IDKCLUBS	 13

#define IDADIAMONDS	 14
#define ID2DIAMONDS	 15
#define ID3DIAMONDS	 16
#define ID4DIAMONDS	 17
#define ID5DIAMONDS	 18
#define ID6DIAMONDS	 19
#define ID7DIAMONDS	 20
#define ID8DIAMONDS	 21
#define ID9DIAMONDS	 22
#define IDTDIAMONDS	 23
#define IDJDIAMONDS	 24
#define IDQDIAMONDS	 25

#define IDKDIAMONDS	 26

#define IDAHEARTS	 27
#define ID2HEARTS	 28
#define ID3HEARTS	 29
#define ID4HEARTS	 30
#define ID5HEARTS	 31
#define ID6HEARTS	 32
#define ID7HEARTS	 33
#define ID8HEARTS	 34
#define ID9HEARTS	 35
#define IDTHEARTS	 36
#define IDJHEARTS	 37
#define IDQHEARTS	 38
#define IDKHEARTS	 39

#define IDASPADES	 40
#define ID2SPADES	 41
#define ID3SPADES	 42
#define ID4SPADES	 43
#define ID5SPADES	 44
#define ID6SPADES	 45
#define ID7SPADES	 46
#define ID8SPADES	 47
#define ID9SPADES	 48
#define IDTSPADES	 49
#define IDJSPADES	 50
#define IDQSPADES	 51
#define IDKSPADES	 52

#define IDGHOST	53

#define IDFACEDOWN1 	54
#define IDFACEDOWN2 	55
#define IDFACEDOWN3 	56
#define IDFACEDOWN4 	57
#define IDFACEDOWN5 	58
#define IDFACEDOWN6 	59
#define IDFACEDOWN7 	60
#define IDFACEDOWN8 	61
#define IDFACEDOWN9 	62
#define IDFACEDOWN10 63
#define IDFACEDOWN11 64
#define IDFACEDOWN12	65

#define IDFACEDOWNFIRST IDFACEDOWN1
#define IDFACEDOWNLAST IDFACEDOWN12

#define IDX 67
#define IDO 68
#define IDMAX IDDECK

/* Внутренние идентификаторы (ID) для анимации */
#define IDASLIME1 678
#define IDASLIME2 679
#define IDAKASTL1 680
#define IDAFLIPE1 681
#define IDAFLIPE2 682
#define IDABROBOT1 683
#define IDABROBOT2 684

/* Красный нелицевой кадр карты */
#define IDFRAME 999

#define FACEUP		0
#define FACEDOWN	1   /* используется для совместимости со старыми приложениями

 IDFACEDOWNFIRST..IDFACEDOWNLAST */
#define HILITE		2
#define GHOST		3
#define REMOVE		4
#define INVISIBLEGHOST 5
#define DECKX		6
#define DECKO		7

 crd.h

#include "cdt.h"

typedef int CD;

// Структура CaRD, описание карты
typedef struct _crd {
    unsigned cd  : 15;		// карта # (1..52)
    unsigned fUp : 1;		// карта рубашкой вверху/внизу
    PT pt;				// верхний левый угол карты
    } CRD;

/* ПРЕДУПРЕЖДЕНИЕ: Соблюдайте порядок */
#define suClub 0
#define suDiamond 1
#define suHeart 2
#define suSpade 3
#define suMax 4
#define suFirst suClub

#define raAce 0
#define raDeuce 1
#define raTres 2
#define raFour 3
#define raFive 4
#define raSix 5
#define raSeven 6
#define raEight 7
#define raNine 8
#define raTen 9
#define raJack 10
#define raQueen 11

#define raKing 12
#define raMax 13
#define raNil 15
#define raFirst raAce

typedef int RA;
typedef int SU;

#define cdNil 0x3c

#define cIDFACEDOWN (IDFACEDOWNLAST-IDFACEDOWNFIRST+1)

#define SuFromCd(cd) ((cd)&0x03)
#define RaFromCd(cd) ((cd)>>2)
#define Cd(ra, su) (((ra)<<2)|(su))
[001650]


Delphi 1

DLL: убийственная утилита

Вот маленький метод, взятый мною из небольшого проекта, созданного мною для удаления DLL из памяти. На форме присутствует одно поле редактирования TEdit с именем EditDLLName, кнопки Ok и Close. Следующий код выполняется при нажатии на кнопке Ok:

procedure TForm1.OkBtnClick(Sender: TObject);
var
hDLL        : THandle;
aName       : array[0..10] of char;
FoundDLL    : Boolean;
begin
if EditDLLName.Text = '' then
begin
MessageDlg('Сначала вы должны ввести имя выгружаемой DLL!',mtInformation,[mbOk],0);
exit;
end;
StrPCopy(aName, EditDLLName.Text);
FoundDLL := false;
repeat
hDLL := GetModuleHandle(aName);
if hDLL = 0 then
break;
FoundDLL := true;
FreeLibrary(hDLL);
until false;
if FoundDLL then
MessageDlg('Успешно!',mtInformation,[mbOk],0)
else
MessageDlg('DLL не найдена!',mtInformation,[mbOk],0);
EditDLLName.Text := '';
end;

[001652]


Delphi 3

Импортирование, или 'обертка' вызовов функций DLL

Импортирование, или 'обертка' вызовов функций DLL

Существует два метода для импорта и загрузки функций из Dynamic Link Library (DLL). Первый метод (который широко обсуждается в данном документе), называется "неявной" (Implicit) загрузкой. Неявная загрузка включает в себя статическую загрузку DLL при запуске программы, и получение доступа к функциям через интерфейс объектного Паскаля. Данный метод должен использоваться в случае, если приложение полностью зависит от загрузки DLL для соответствующего функционирования. Другой метод доступа называется "явной" загрузкой, поскольку DLL загружается динамически по требованию. Этот метод требует дополнительного кодирования и должен использоваться, если приложению нужно работать в случае, даже если DLL не смогла правильно загрузиться.

Что такое "обертка" функциональных вызовов?

Обертка функции, или набора функций, состоит из объявлений в секции interface и кода в секции implementation (вместе со связанными константами или типами), которые соответствуют функции, или набору функций, импортируемых из DLL. Обертка является простой декларацией в паскалевском модуле, которая обеспечивает точку входа в DLL. В Delphi обертка представляет собой файл модуля, содержащий код объектного паскаля. Группа разработчиков Delphi уже создала для вас обертку функций и стандартных элементов управления Windows. Но иногда возникает необходимость создания обертки для вызовов функций dll, но это в Delphi не обернуто по случаю сугубой индивидуальности каждой DLL и входящих в нее функций.

Первым, и самым сложным шагом в данном процессе является получение информации о функциях. Один из лучших источников для получения документации об имеющихся (доступных) в DLL функций является World Wide Web. Начать поиск можно с MSDN, а если и там нет информации, то можно обратиться к многочисленным поисковым серверам, которые частенько находят нужную вам информацию. Для получения структуры вызовов функций ищите залоговочные файлы C++ в продуктах типа Borland C++ или MS Visual C++. Соглашения об вызовах и преобразованиях типов обычно способны разрешить конфликты и несовместимость вызовов между C++ и PASCAL. Хороший ресурс по вопросам совместимости между Delphi и C++ расположен на сайте Borland по адресу: "http://www.borland.com/delphi/papers/brick.html".

После того, как вы нашли необходимый пример, или документацию об экспортируемых DLL функциях, то следующим шагом будет создание нового модуля. Интерфейс модуля будет содержать константы и типы, необходимые для вызова отдельных функций DLL, и заголовки самих функций. Данные заголовки функций являются объектно-паскалевским интерфейсом, позволяющим другим приложениям Delphi вызывать функции рассматриваемой DLL. Как только секция модуля interface будет завершена, следующей секцией будет implementation. Секция модуля implementation содержит объявления импортируемых внешних функций. Эти заголовки не идентичны тем, которые расположены в секции модуля interface (которые содержат реальные идентификаторы функций плюс другую важную информацию для реализации). Для получения дополнительной информации по этой теме обратитесь к топику "DLLs:accessing procedures and functions" справки помощи по Delphi 3.

Представим себе, что у нас есть функция с именем BOB в DLL с именем 'BLODGE.DLL'. (ниже приведены подробные и необходимые шаги, где подразумевается, что мы будем использовать неявную загрузку DLL):

  1. Поиск информации по Интернету показал, что функция BOB должна возвращать логическое значение и требует в качестве аргументов значения типа word и boolean.
  2. Создайте в Delphi новый файл модуля с именем 'UseBob.pas' (File|New и выберите unit)
  3. Следующая строка кода должна располагаться в секции interface нового модуля:

    function BOB(Fire: Word; Dances: Boolean): Boolean; stdcall;

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

    function BOB; external 'BLODGE';

  5. Сохраните модуль с именем 'UseBob.pas'.
  6. Необходимо убедиться в том, что UseBob.pas расположен в каталоге текущего проекта, или находится в каталоге, прописанном в путях поиска Delphi.
  7. Добавьте к списку uses модуля нового проекта модуль 'UseBob'. Теперь функция BOB может быть вызвана из нового проекта подобно любой другой стандартной функции.
  8. Во время выполнения приложения BLODGE.DLL должен находится в пути текущих переменных окружения процесса.
Для способа, при котором 'BLODGE.DLL' должна быть загружена явно, требуется дополнительное кодирование. Как было подчеркнуто выше, необходимо знание аргументов функций/процедур (и тип результата в случае функции).

Ниже приведен модуль с реализацией вызова функции BOB, инициализируемый при нажатии на кнопку:

unit UDLLTest;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

{ Вот типы, которые требуются для работы нашей функции bob }
TBOB = function(Fire: Word; Dances: Boolean): Boolean; stdcall;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
BOB: TBOB;
hDLLInst: THandle;
IsAlive,IsDancing: Boolean;
Years: Word;

begin
{ Загружаем и получаем дескриптор нашего BLODGE.DLL }
hDLLInst:= LoadLibrary('BLODGE.DLL');
{ Если загрузка не была успешной, генерируем свое исключение }
if (hDLLInst <= 0) then
raise exception.create('[Неудачный вызов LoadLibrary]');
{ Попытаемся получить адрес функции BOB }
try
@BOB:= GetProcAddress(hDLLInst,'BOB');
if not assigned(BOB) then
raise exception.Create('[Неудачный вызов GetProcAddress]');
Years:= 25;
IsDancing:= True;
{ Теперь мы можем выполнить функцию BOB }
IsAlive:= BOB(Years,IsDancing);
finally
{ Освобождаем дескриптор DLL }
FreeLibrary(hDLLInst);
end;
end;
end.

[001655]


Delphi 1

Uses в DLL

...синтаксис для DLL должен быть немного другим. Вот как нужно правильно делать:

Вам необходимо, по крайней мере, два файла -- библиотечный файл и файл с исходным кодом:

Библиотечный файл: mylib.dpr

library MyLib;

uses
MyCode in 'MYCODE.PAS';

exports
MyFunc index 1;

begin
end.

Файл с исходным кодом: mycode.pas

unit MyCode;

interface

function MyFunc( MyParam: string ): string; export;

implementation

function MyFunc( MyParam: string ): string;

begin
Result := 'Это просто пример!';
end;

end.

Совет написан по мотивам книги Delphi Developer's Guide, изданной издательством Borland Press/Sams Publishing. [001657]


Delphi 1

Функции VER.DLL

Это не в точности то, что вы ищите, но надеюсь, что это поможет. Я показываю информацию о версии в диалоговом окне "О программе", код приведен ниже. Блок StringFileInfo вы можете и не использовать, он необходим для осуществления простейшей проверки, вместо этого можно получить информацию из корневого блока (для дополнительной информации смотри структуру TVS_FIXEDFILEINFO в файле помощи по API).

procedure TAboutBox.FormCreate(Sender: TObject);
var
VIHandle : LongInt;
VSize : LongInt;
VData : Pointer;
VVers : Pointer;
Len : Word;
FileName : String;

const
Prefix = '\StringFileInfo\040904E4\'; { Предустановленный набор символов U.S.,
если я правильно помню }
function GetVerValue(Value : String) : String;
var
ItemName : String;

begin
ItemName := Prefix + Value + chr(0);
Result := '';
If VerQueryValue(VData,@ItemName[1],VVers,Len)
Then
If Len > 0
Then
Begin
If Len > 255
Then
Len := 255; { "Обрезаем" любые длинные строки }
Move(VVers^, Result[1], Len);
Result[0] := Chr(Len);
End;
end;

begin
FileName := Application.EXEName + chr(0);
VSize := GetFileVersionInfoSize(@FileName[1], VIHandle);
If VIHandle <> 0
Then
Begin
GetMem(VData, VSize);
Try
If GetFileVersionInfo(@FileName[1], VIHandle, VSize, VData)
Then
Begin
{ В этом месте мы получаем значения из блока StringFileInfo,
но точно также мы могли бы взять значения из корневого блока,
используя VerQueryValue }
ProductName.Caption := GetVerValue('ProductName');
Version.Caption := GetVerValue('ProductVersion');
Copyright.Caption := GetVerValue('LegalCopyright');
Comments.Caption := GetVerValue('FileDescription');
End;
Finally
FreeMem(VData, VSize);
End;
End;
end;

[001658]


Опыт читателя

Как работать с плагинами?

Из советов Nomadic'a:

Я сделал так - выбираю все DLL из каталога с программой, загружаю каждую и пытаюсь найти в ней функцию (через API GetProcAddress) с заранее определенным жестко именем (например что нибудь типа IsPluginForMyStuff). Если нашлась - DLL считается моим плагином, если нет - выгрузить и забыть.

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

Вот часть моего кода по работе с плагинами...

...
type
// Процедурные типы для хранения ссылок на функции плагинов
TGetNProc=function:shortstring;
TGetSProc=function:integer;
TProcessProc=procedure(config:pointer; request:PRequest; var reply:PReply);
TConfigProc=procedure(defcfg:PSysConfig; var config:pointer);
TSaveLoadProc=procedure(inifile:pointer; var config:pointer);

// Информация об отдельном плагине
TPlugin=record
Name:shortstring;                   // Полное название
Filename:shortstring;               // Имя файла
Handle:integer;                     // Хэндл загруженной DLL
CFGSize:integer;                    // Размер конфигурации в RAM
ProcessProc: TProcessProc;      // Адрес процедуры обработки
ConfigProc: TConfigProc;       // Адрес процедуры настройки
LoadCFG,SaveCFG:TSaveLoadProc;      // Адреса процедур чтения/записи cfg
end;
PPlugin=^TPlugin;

// Список загруженных плагинов
TPlugins=class(TList);

...

var
Plugins:TPlugins;  sr:TSearchRec;  lib:integer;
pgetn:TGetNProc;  pgets: TGetSProc;  plugin:PPlugin;

...

// Читаем плагины и создаем их список.
Plugins:=TPlugins.Create;
if FindFirst('*.dll',faAnyFile,sr)<>0 then begin
ShowMessage('Hе найдено подключаемых модулей.');
Close;
end;
repeat
lib:=LoadLibrary(PChar(sr.Name));
if lib<>0 then begin
@pgetn:=GetProcAddress(lib, 'GetPluginName');
if @pgetn=nil then FreeLibrary(lib)    // Hе плагин
else begin
New(plugin);
@pgets:=GetProcAddress(lib, 'GetCFGSize');
plugin.Name:=pgetn;
plugin.Filename:=sr.Name;
plugin.CFGSize:=pgets;
plugin.Handle:=lib;
plugin.ConfigProc:=GetProcAddress(lib, 'Configure');
plugin.ProcessProc:=GetProcAddress(lib, 'Process');
plugin.SaveCFG:=GetProcAddress(lib, 'SaveCFG');
plugin.LoadCFG:=GetProcAddress(lib, 'LoadCFG');
Plugins.Add(plugin);
end;
end;
until FindNext(sr)<>0;
FindClose(sr);
...

[001677]


Письмо читателя

Можно ли определить полный путь и имя файла запущенной DLL из самой DLL?

Своим опытом делится Олег Кулабухов:

uses Windows;
procedure ShowDllPath stdcall;
var
TheFileName : array[0..MAX_PATH] of char;
begin
FillChar(TheFileName, sizeof(TheFileName), #0);
GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
end;

[001843]


Читаем Adobe Acrobat PDF файлы из нашего приложения

Igor Nikolaev aKa The Sprite советует:

Adobe Acrobat PDF - хорошо извесный формат, который нравится многим пользователям. Давайте посмотрим, как можно заставить приложение на Delphi прочитать файл такого формата.

Совместимость: Delphi 3.x (или выше)

Итак, Вы должны быть уверены, что у вас проинсталлирован Acrobat Reader, елси таковой программы нет, то её можно скачать с www.adobe.com После этого необходимо проинсталировать типовую библиотеку для Acrobat (Project -> Import Type Library из меню Delphi) выберите "Acrobat Control for ActiveX (version x)". Где x - текущая версия библиотеки. Hажмите кнопку инсталяции. Теперь создайте новое приложение, поместите на форму проинсталлированный компонент TPDF, далее добавите OpenDialog, и в заключении кнопку, при на нажатии на которую будет вызываться процедура открытия файла:

procedure
TForm1.Button1Click(Sender: TObject);
begin
if
OpenDialog1.Execute then
pdf1.src :=
OpenDialog1.FileName;
end;

в юните PdfLib_TLB вы можете найти интерфейс класса TPdf:

TPdf = class(TOleControl)

private
FIntf: _DPdf;

function  GetControlInterface:
_DPdf;
protected
procedure
CreateControl;
procedure InitControlData;
override;
public

function  LoadFile(const fileName:
WideString): WordBool;
procedure
setShowToolbar(On_: WordBool);
procedure
gotoFirstPage;
procedure gotoLastPage;

procedure gotoNextPage;

procedure gotoPreviousPage;

procedure setCurrentPage(n: Integer);

procedure goForwardStack;

procedure goBackwardStack;

procedure setPageMode(const pageMode:
WideString);
procedure setLayoutMode(const
layoutMode: WideString);
procedure
setNamedDest(const namedDest: WideString);

procedure Print;

procedure printWithDialog;

procedure setZoom(percent: Single);

procedure setZoomScroll(percent: Single; left:
Single; top:

Single);
procedure setView(const viewMode:
WideString);
procedure setViewScroll(const
viewMode: WideString; offset:

Single);
procedure setViewRect(left: Single;
top: Single; width: Single;

height: Single);
procedure printPages(from:
Integer; to_: Integer);
procedure
printPagesFit(from: Integer; to_: Integer; shrinkToFit:

WordBool);
procedure printAll;

procedure printAllFit(shrinkToFit: WordBool);

procedure setShowScrollbars(On_: WordBool);

procedure AboutBox;

property  ControlInterface: _DPdf
read GetControlInterface;

property  DefaultInterface: _DPdf
read GetControlInterface;
published

property  TabStop;

property  Align;

property  DragCursor;

property  DragMode;

property  ParentShowHint;

property  PopupMenu;

property  ShowHint;

property  TabOrder;

property  Visible;

property  OnDragDrop;

property  OnDragOver;

property  OnEndDrag;

property  OnEnter;

property  OnExit;

property  OnStartDrag;

property src: WideString index 1 read
GetWideStringProp write

SetWideStringProp
stored False;
end;

в заключение можно добавить следующее: Если Вы не уверены, что у конечного пользователя Вашей программы установлен Acrobat Reader, то необходимо, чтобы приложение проверяло эту ситуацию, прежде чем будут производится различные манипуляции с компонентой TPdf. И второе, если файл PDF имеет различные связи, например с AVI файлами, то они не будут работать из Delphi.

Hадеюсь этот пример будет Вам полезен. [001471]


Какие есть рекомендации по использованию Apollo SDE?

Nomadic советует:

  1. При работе с Аполло (если у тебя базы используются и досовскими задачами) - то в dbgrid'e поставь значение Font->Charset = OEM_Charset. И не забудь сразу после открытия базы вызывать метод Apollo1.SetTranslate(True). Если твое приложение будет работать с базами одновременно с досовскими, то советую перед открытием баз вызывать метод Apollo1.SysProp( SDE_SP_SETOBUFFER, Pointer( 0 ) ); для отключения буферизации операций чтения/записи в базы.

  2. Если ты пишешь приложение, которое будет использовать базы только в кодировке Windows (CP1251), то тебе достаточно будет указать в dbgrid'e значение Font->Charset = Russian_Charset.
Если базы в 866 кодиpовке, то:
  1. Использование TTable + TApollo:

    === Cut ====

    TTable.Open;
    TApollo.SetTranslate(True);
    TTable.Refresh;

    === Cut ====

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

    === Cut ====

    TApTable.Open;
    TApTable.SetTranslate(True);
    TApTable.Refresh;

    === Cut ====

    И вместо закоpючек бyдyт pодные pyсские бyквы. Пpавда, только пpи выполнении пpогpаммы. В дизайнеpе на этапе пpоектиpования псевдогpафика так и останется. [001301]


Не работает передача данных по OLE в русский Excel

Nomadic отвечает:

A: (SM): Дело в том что в VCL твои команды OLE2 передаются Excel'у в русском контексте (не знаю, как это правильно назвать). Для исправления необходимо найти в файле OLEAUTO.pas в функции GetIDsOfNames строчку

if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then

и заменить ее на

if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
((LANG_ENGLISH+SUBLANG_DEFAULT*1024)+SORT_DEFAULT* 65536 ),
DispIDs) <> 0 then

После этого у меня Excel стал понимать нормальные английские команды :)). Необходимая комбинация для установки английского языка взята из C-шных хедеров. [001498]


Как отследить открытие и закрытие документов в приложении Microsoft Word?

Nomadic советует:

В копилку. Исходный код, FAQ - желающие могут взять с Internet сами (информация взята с http://www.softmosis.ca, проверено - работает).

Основной модуль, регистрация и вызов

...
public
{ Public declarations }
FWordApp: _Application;
FWordDoc: _Document;
FWordSink: TWordConnection;
...

procedure StartWordConnection(WordApp: _Application;
WordDoc: _Document;
var WordSink: TWordConnection);
var
PointContainer: IConnectionPointContainer;
Point: IConnectionPoint;
begin
try
// TWordConnection is the COM object which receives the
// notifications from Word. Make sure to free WordSink when
// you are done with it.
WordSink := TWordConnection.Create;
WordSink.WordApp := WordApp;
WordSink.WordDoc := WordDoc;

// Sink with a Word application
OleCheck(WordApp.QueryInterface(IConnectionPointContainer, PointContainer));
if Assigned(PointContainer) then begin
OleCheck(PointContainer.FindConnectionPoint(ApplicationEvents, Point));
if Assigned(Point) then
Point.Advise((WordSink as IUnknown), WordSink.AppCookie);
end;

// Sink with a Word document advise
OleCheck(WordDoc.QueryInterface(IConnectionPointContainer, PointContainer));
if Assigned(PointContainer) then begin
OleCheck(PointContainer.FindConnectionPoint(DocumentEvents, Point));
if Assigned(Point) then
Point.Advise((WordSink as IUnknown), WordSink.DocCookie);
end;

except
on E: Exception do ShowMessage(E.Message);
end;
end;

procedure TmainForm.btnStartClick(Sender: TObject);
begin
FWordApp := CoApplication_.Create;
FWordDoc := FWordApp.Documents.Add(EmptyParam, EmptyParam);
FWordApp.Visible := True;
StartWordConnection( FWordApp, FWordDoc, FWordSink );
end;

procedure TmainForm.btnExitClick(Sender: TObject);
begin
FWordApp.Quit(EmptyParam, EmptyParam, EmptyParam);
end;

Модуль отслеживания линков

unit ConnectionObject;
interface

uses Word_TLB, dialogs;

type

TWordConnection = class(TObject, IUnknown, IDispatch)
protected

{IUnknown}
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;

{ IDispatch }
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

public
WordApp: _Application;
WordDoc: _Document;
AppCookie, DocCookie: Integer;
end;

implementation

{ IUnknown Methods }

uses windows, activex, main;

procedure LogComment(comment: string);
begin
Form1.Memo1.Lines.Add(comment);
end;

function TWordConnection._AddRef: Integer;
begin
Result := 2;
end;

function TWordConnection._Release: Integer;
begin
Result := 1;
end;

function TWordConnection.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
Result := E_NOINTERFACE;
Pointer(Obj) := nil;
if (GetInterface (IID, Obj)) then Result := S_OK;
if not Succeeded (Result) then
if (IsEqualIID(IID, DocumentEvents) or IsEqualIID(IID, ApplicationEvents))
then if (GetInterface(IDispatch, Obj)) then Result := S_OK;
end;

{ IDispatch Methods }

function TWordConnection.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;

function TWordConnection.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;

function TWordConnection.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := E_NOTIMPL;
end;

function TWordConnection.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
//This is the entry point for Word event sinking
Result := S_OK;
case DispID of
1: ; // Startup
2: ShowMessage( 'quit' ); // Quit
3: ; // Document change
4: ; // New document
5: ; // Open document
6: ShowMessage( 'close' ); // Close document
else Result := E_INVALIDARG;
end;
end;

end.

[001080]


Delphi 3

Автоматизация WORD 7

Вы можете воспользоваться любым интерфейсом, предлагаемым сервером автоматизации Word. Все реализованные интерфейсы вы можете увидеть при загрузке MSWORD8.OLB в Delphi, данный файл представляет собой библиотеку типов Word 7. Для исполнения VB в Word вы можете использовать свойство WordBasic Application. Следующий пример демонстрирует оба метода:

implementation

uses ComObj;

{$R *.DFM}

var
V: OleVariant;

procedure TForm1.Button1Click(Sender: TObject);
begin
V := CreateOleObject('Word.Application');
V.ShowMe;
V.WordBasic.FileNew;
V.WordBasic.Insert('тест');
V.Run('mymac');
V.WordBasic.FileSave;
end;

end.

[001147]


Как мне работать с файлами MS Word или таблицами MS Excel?

Nomadic отвечает:

A: Воспользоваться функцией CreateOLEObject и работать с VBA (Visual Basic for Applications) или WordBasic.

NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например, FileOpen(Name := 'myname.doc');

=== Cut Пример ===

Пример проверен только на русском Word 7.0! Может, поможет...

unit InWord;
interface
uses
... ComCtrls; // Delphi3
... OLEAuto;  // Delphi2
[skip]
procedure TPrintForm.MPrintClick(Sender: TObject);
var W: Variant;
S: String;
begin
S:=VarToStr(Table1['Num']); //В D3 без промежуточной записи
// в var у меня не пошло :(
try // А вдруг где ошибка :)
W:=CreateOleObject('Word.Basic');
// Создаем документ по шаблону MyWordDot
// с указанием пути если он не в папке шаблонов Word
W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);
// Отключение фоновой печати (на LJ5L без этого был пустой лист)
W.ToolsOptionsPrint(Background:=0);

// Переходим к закладке Word'a 'Num'
W.EditGoto('Num'); W.Insert(S);
//Сохранение
W.FileSaveAs('C:\MayPath\Reports\MyReport')
W.FilePrint(NumCopies:='2'); // Печать 2-х копий
finally
W.ToolsOptionsPrint(Background:=1);
W:=UnAssigned;
end;
end;
{.....}

=== Cut Конец примера === [001561]


Передача переменных отчета в ReportSmith III

...вы говорите можно передавать переменные? В документации только красивые схемы. Я пытаюсь передать две даты, но мне необходимо чтобы первую дату ввел пользователь, вторую я вычисляю в Delphi сам и передаю результат ReportSmith.

Вот кусор работающего у меня кода, передающий использующийся при выборе Timestamp. Я использую строковую переменную просто как способ проверить строку прежде, чем я ее добавлю в отчет. Если вы хотите, можете это убрать. Примечание: убедитесь в том, что переменная, которой вы передаете значение, написана верно. Переменные отчета Reportsmith ЧУСТВИТЕЛЬНЫ К РЕГИСТРУ.

Var S : String;
Begin
ExportReport.InitialValues.Clear;
S :='@SQLDate=<'''+FormatDateTime('mm/dd/yyyy hh:nn:ss',ATimeStamp)+'''>';
ExportReport.InitialValues.Add(S);
ExportReport.RUN;
End;

- Steve McWhirter [001013]


Как правильно работать с SQLAnywhere через BDE -> ODBC -> SAW?

Nomadic советует:

  1. Необходимо поставить patch на ODBC-драйвер (доступен на www.sybase.com);

  2. Достаточно флажка Keys in SQL Statistics в ODBC-администpатоpе, для того, чтобы исчезла необходимость ставить втоpичные индексы по ключевым полям;

  3. Если Вы пользуетесь BDE 3.5, то обновите ее до версии 4.x, или замените idodbc.dll на тот, который идет в комплекте поставки BDE 3.0.
[001313]


Delphi 1

Пример ресурсной таблицы строк

Как мне создать ресурсную таблицу строк (Resource String Table), про которую упоминается в функции FmtLoadStr, но не сказано как создать эту таблицу, про это вообще нигде не сказано!

Создайте файл в приведенном ниже формате и обзовите его, скажем (подойдите к этому творчески), strings.rc:

  STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE
  {
   1, "UNPACK.INI"
   2, "AcrobatClass"
   3, "ACROEXCH.EXE"
   4, "^.PDF"
   5, "Extensions"
   6, "ACROEXCH.EXE"
   7, "PDF"
   8, "AABSETUP.EXE"
   9, "DelFiles-"
   10, "INI-"
   11, "UNPACK.INI"
   12, "ACROSRCH.DLL"
   13, "Regedit"
   14, "ACROREAD.EXE"
   15, "ACRO_LE.EXE"
  }
Затем, с помощью компилятора ресурсов Borland (BRCC.EXE в вашем каталоге Delphi\Bin), скомпилируйте это в файл ресурсов:

 BRCC strings.rc
Вы получите файл с именем strings.res. В вашем .DPR-файле после строки {$R *.RES} добавьте строку {$R STRINGS.RES}, после этого строковые ресурсы будут компилироваться с вашим exe-файлом.

- Ralph Friedman [001051]


Компиляция ресурсов

У меня имеется приблизительно 36 маленьких растровых изображений, которые я хочу сохранить в файле и затем прилинковать его к exe. Как мне поместить их в res-файл?

Самый простой путь - создать файл с именем "BITMAPS.RC" и поместить в него список ваших .BMP-файлов:

BMAP1 BITMAP BMAP1.BMP
BMAP2 BITMAP BMAP2.BMP
CLOCK BITMAP CLOCK.BMP
DBLCK BITMAP DBLCK.BMP
DELOK BITMAP DELOK.BMP
LUPE BITMAP LUPE.BMP
OK BITMAP OK.BMP
TIMEEDIT BITMAP TIMEEDIT.BMP
Затем загрузите Resource Workshop (RW) и выберите пункт меню File|Project Open. В выпадающем списке "File Type" (тип файла) выберите RC-Resource Script и откройте файл, который вы только что создали. После того, как RW загрузит ваш файл, выберите пункт меню File|Project save as. Выберите объект RES-Resource из выпадающего списка "File Type" (тип файла). В поле редактирования "New File name" задайте имя нового файла, скажем, BITMAPS.RES. Нажмите OK. Теперь у вас есть файл ресурса. В вашем модуле Delphi добавьте после строки {$R *.RES} строку {$R BITMAPS.RES}. После компиляции вы получите exe-файл с скомпилированными ресурсами. Для получения доступа к ресурсам во время выполнения программы нужно сделать следующее:

myImage.Picture.Bitmap.Handle := LoadBitmap(HInstance, 'TIMEEDIT');

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

-Ralph Friedman [001099]


Delphi 1

Ошибка дублирования идентификатора ресурса

У вас есть исходный код VCL? Если да, то в этом случае ее можно всю перекомпилировать, добавив каталог к вашему библиотечному пути (Library path) в опциях среды (Environment Options | Library). Я думаю это нужно сделать, чтобы отделаться от этой ошибки. При другом способе необходимо вычислить вызывающую проблему директиву $R, временно удалить ее, и осуществить перекомпиляцию. Временно выключить директиву $R можно добавлением '.' перед $ (но это не единственный путь выключить ее).

Вероятно, вы сабкласситесь от VCL. Убедитесь в том, что идентификатор ресурса для вашей иконки уникальный. Просто загрузите ее в любой редактор ресурсов, и измените ее номер. После этого вы должны пересобрать вашу библиотеку. [001440]


Письмо читателя

Сохранение и выдёргивание ресурсов в DLL или EXE

Иногда возникает необходимость вшить ресурсы в исполняемый файл Вашего приложения (например чтобы предотвратить их случайное удаление пользователем, либо, чтобы защитить их от изменений). Данный пример показывает как вшить любой файл как ресурс в EXE-шнике. Совместимость: Delphi 3.x (или выше)

Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:

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

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

TResHeader = record
DataSize: DWORD;        //    размер данных??????
HeaderSize: DWORD;      // размер этой    записи
ResType: DWORD;         //    нижнее слово = $FFFF => ordinal
ResId: DWORD;           //    нижнее слово = $FFFF => ordinal
DataVersion: DWORD;     // *
MemoryFlags: WORD;
LanguageId: WORD;       // *
Version: DWORD;         // *
Characteristics: DWORD; // *
end;

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

Листинг 1:

procedure CreateResourceFile(
DataFile, ResFile: string;  // имена файлов
ResID:    Integer              //    id ресурсов
);
var
FS, RS: TFileStream;
FileHeader, ResHeader: TResHeader;
Padding: array[0..SizeOf(DWORD)-1] of Byte;
begin
{ Open input file and create resource file }
FS := TFileStream.Create(  // для чтения данных из    файла
DataFile, fmOpenRead);
RS := TFileStream.Create(  // для записи файла    ресурсов
ResFile, fmCreate);
{ Создаём заголовок файла ресурсов - все    нули, за исключением
HeaderSize, ResType и ResID }
FillChar(FileHeader, SizeOf(FileHeader), #0);
FileHeader.HeaderSize := SizeOf(FileHeader);
FileHeader.ResId := $0000FFFF;
FileHeader.ResType := $0000FFFF;
{ Создаём заголовок данных для RC_DATA файла
Внимание: для создания более одного    ресурса необходимо
повторить следующий процесс,    используя каждый раз различные
ID ресурсов }
FillChar(ResHeader, SizeOf(ResHeader), #0);
ResHeader.HeaderSize := SizeOf(ResHeader);
// id ресурса - FFFF означает "не строка!"
ResHeader.ResId := $0000FFFF or (ResId shl 16);
// тип ресурса - RT_RCDATA (from Windows unit)
ResHeader.ResType := $0000FFFF
or (WORD(RT_RCDATA) shl 16);
// размер данных - есть размер файла
ResHeader.DataSize := FS.Size;
// Устанавливаем необходимые флаги памяти
ResHeader.MemoryFlags := $0030;
{ Записываем заголовки в файл ресурсов }
RS.WriteBuffer(FileHeader, sizeof(FileHeader));
RS.WriteBuffer(ResHeader, sizeof(ResHeader));
{ Копируем файл в ресурс }
RS.CopyFrom(FS, FS.Size);
{ Pad data out to DWORD boundary - any old
rubbish will do!}
if FS.Size mod SizeOf(DWORD) <> 0 then
RS.WriteBuffer(Padding, SizeOf(DWORD) -
FS.Size mod SizeOf(DWORD));
{ закрываем файлы }
FS.Free;
RS.Free;
end;

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

Листинг 2:

procedure ExtractToFile(Instance:THandle; ResID:Integer; ResType,
FileName:String);
var
ResStream: TResourceStream;
FileStream: TFileStream;
begin
try
ResStream := TResourceStream.CreateFromID(Instance, ResID,
pChar(ResType));
try
//if FileExists(FileName) then
//DeleteFile(pChar(FileName));
FileStream := TFileStream.Create(FileName, fmCreate);
try
FileStream.CopyFrom(ResStream, 0);
finally
FileStream.Free;
end;
finally
ResStream.Free;
end;
except
on E:Exception do
begin
DeleteFile(FileName);
raise;
end;
end;
end;

Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или Application.Handle, для dll Вам прийдётся получить его самостоятельно :) ResID тот же самый ID , который был присвоен ресурсу ResType WAVEFILE, BITMAP, CURSOR, CUSTOM - это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM FileName - это имя файла, который мы хотим создать из ресурса

Пока ..

Igor Nikolaev aKa The Sprite
[spritesoft@bos.ru] [001450]


Письмо читателя

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

В файл MyWave.rc пишешь:

MyWave RCDATA LOADONCALL MyWave.wav
brcc32.exe MyWave.rc, получаешь MyWave.res.

В своей программе пишешь:

{$R MyWave.res}

Все!

Предупреждая следующий твой вопрос "а как прочитать wave-файл из исполняемого файла?"

procedure RetrieveMyWave;
var
hResource: THandle;
pData: Pointer;
begin
hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDA
TA));
try
pData := LockResource(hResource);

if pData = nil then
raise Exception.Create('Cannot read MyWave');

// Здесь pData указывает на MyWave
// Теперь можно, например, проиграть его (Win32):
PlaySound('MyWave', 0, SND_MEMORY);
finally
FreeResource(hResource);
end;
end;

Nomadic [001554]


Письмо читателя

Есть программа на Delphi, котоpая отображает какой-то html. В html используется gif-файл. Как в Delphi-пpоекте указать, чтобы этот gif находился в exe как некий кусок кода. А когда надо будет, записать его обратно в gif-файл без изменений, выковырнув из exe?

Можно, используя RxLib. После его установки в меню View появится пунктик Project Resources. Hужно выбрать Project Resources->New->User Data и добавить нужный файл. В данном случае ресурс был назван "RCDATA_1".

Если RxLib нет, то нужно создать файл описания ресурсов:

=== Begin gifs.rc ===
mygif rcdata "имя_gif-файла.gif"
mygif1 rcdata "RCDATA_1"
=== End dots.rc ===
Потом скомпилировать его командой brcc32 gifs.rc и получить gifs.res В начало модуля добавь строчку {$R gifs.res}

В своей программе необходимо написать:

var
rs     : TResourceStream;
a      : Pointer;
begin
rs:=TResourceStream.Create(hinstance,'RCDATA_1',RT_RCDATA);
try
GetMem(a,rs.size);
rs.Read(a^,rs.size);  {Теперь a - динамический указатель на код}

{ Здесь делается все, что необходимо с кодом, используя указатель a }

FreeMem(a);
finally
rs.Free;
end;
end;

А можно и так, если необходимо записать ресурс в файл:

var
rs     : TResourceStream;
fs     : TFileStream;
begin
rs:=TResourceStream.Create(hInstance, 'mygif', RT_RCDATA);
fs:=TFileStream.Create('имя_gif-файла.gif', fmCreate);
try
fs.CopyFrom(rs, rs.Size);
finally
fs.Free;
rs.Free;
end;
end;

Nomadic [001649]


Письмо читателя

Как DLL правильно заполнить строковыми ресурсами, и потом достать их?

Делаешь текстовый файл с ресурсами, типа

--my.rc--
STRINGTABLE
{
00001, "My String #1"
00002, "My String #2"
}
Далее компилируешь его:
brcc32 my.rc
У тебя получится my.res.

Делаешь DLL:

--my.dpr--

library my;
{$R my.res}
begin
end.

Компилируешь Дельфиским компилятором:

dcc32 my.dpr
Получаешь, наконец-то свою my.dll

Теперь о том, как использовать.

В своей программе:

var
h : THandle;
S: array [0..255] of Char;
begin
h := LoadLibrary('MY.DLL');
if h <= 0 then ShowMessage('Bad Dll Load')
else
begin
SetLength(S, 512);
LoadString(h, 1, @S, 255);
FreeLibrary(h);
end;
end;

Nomadic [001689]


Копирование проекта в новый каталог

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

Самый простой путь сделать это:

  1. "Save Project As" (сохранить проект как) в ваш новый каталог.
  2. Для каждого PAS-файла проекта сделайте операцию "Save As" (сохранить как)
  3. Запустите View/ProjectManager для проверки отсутствия ссылок на старый каталог
Если вы уже скопировали PAS-файлы в новый каталог, то в качестве альтернативы к п.(2) могу предложить воспользоваться кнопками плюс/минус в Менеджере Проекта (Project Manager), это поможет вам удалить старое и добавить файлы из нового каталога.

- Mike Orriss [001060]


Delphi 2

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

...я все еще ищу *крутой* способ отрисовки содержимого окна редактирования IDE, и уже добрался до списка дескрипторов окон. Я так понял, что для этого нужно использовать инструментальный интерфейс (Tools Interface), только c помощью него, да? Ну и как этим чудом воспользоваться?

Приведенный ниже код может использоваться для включения заголовка исходного кода, представляющего собой шапку с информацией об авторских правах, авторе, версии и пр. при добавлении нового модуля или формы к вашему проекту. TIAddInNotifier - класс, реализованный в ToolIntf и позволяющий "захватывать" такие события, как открытие файлов, их закрытие, открытие и закрытие проекта и др. Я перекрыл процедуру FileNotification для захвата событий AddedToProject и RemovedFromProject. В обработчике события AddedToProject вы можете получить доступ к новому модулю проекта, особенно это касается процедуры InsertHeader. Я создал наследника класса TIEditorInterface, расположенного в файле EditIntf.pas, и создал собственную процедуру InsertHeader.

VCSNotifier создается в другом модуле и здесь не показан. Приведенный ниже код является частью моей программы, осуществляющей контроль версий dll. При создании код "живет" до тех пор, пока работает Delphi. При получении кода AddedToProject, я проверяю наличие файла (должен быть новым), и что он является .pas-файлом. Затем я создаю VCSEditorInterface, мой унаследованный интерфейс, и использую мою процедуру InsertHeader.

В самой процедуре InsertHeader я создаю экземпляр TIEditReader для чтения нового модуля и TIEditWriter для его изменения.

unit VCSNtfy;

interface

uses SysUtils, Dialogs, Controls, ToolIntf, EditIntf;

type
TIVCSNotifier = class( TIAddInNotifier )
public
procedure FileNotification(NotifyCode: TFileNotification; const FileName:
string; var Cancel: Boolean ); override;
end;

TIVCSEditorInterface = class( TIEditorInterface )
public
procedure InsertHeader;
end;

var
VCSNotifier : TIVCSNotifier;
VCSModuleInterface : TIModuleInterface;
VCSEditorInterface : TIVCSEditorInterface;

implementation

uses FITIntf, FITStr, Classes;

{ *************************   Начало VCSNotifier  **************************** }

procedure  TIVCSNotifier.FileNotification( NotifyCode: TFileNotification; const
FileName: string; var Cancel : Boolean );
var
TmpFileName : string;

begin
case NotifyCode of
fnRemovedFromProject: VCSProject.Remove( LowerCase( ExtractFileName(
FileName )));
fnAddedToProject: begin
if ( not FileExists( FileName ) ) and
( ExtractFileExt( FileName ) = '.pas' ) then
begin
{ новый файл с исходным кодом }
VCSModuleInterface := ToolServices.GetModuleInterface( FileName );
if VCSModuleInterface <> nil then
begin
VCSEditorInterface := TIVCSEditorInterface(
VCSModuleInterface.GetEditorInterface );
VCSEditorInterface.InsertHeader;
VCSEditorInterface.Free;
end;
VCSModuleInterface.Free;
end;

TmpFileName := LowerCase( ExtractFileName( FileName ));
if VCSProject.RecycleExists( TmpFileName ) then
begin
if MessageDlg( 'Вы хотите извлечь текущие ' +
' записи из таблицы Recycle' +
#13 + #10 + '           ' +
VCSProject.ProjectName + '/' +
TmpFileName + '?', mtConfirmation,
[mbYes,mbNo], 0 ) = mrYes then
begin
VCSProject.Recycle( TmpFileName );
end;
end;
end;
end;
end;

{ *************************    Конец TIVCSNotifier   *************************** }

{ *********************   Начало TIVCSEditorInterface  ************************ }
procedure TIVCSEditorInterface.InsertHeader;
var
Module, TmpFileName, UnitName, InsertText, Tmp : string;
Reader : TIEditReader;
Writer : TIEditWriter;
APos : Integer;
F : TextFile;
begin

TmpFileName := ExtractFileName( FileName );
UnitName := SwapStr( TmpFileName, '.pas', '' );

SetLength( Module, 255);
Reader := CreateReader;
try
Reader.GetText( 0, PChar( Module ), Length( Module ));
finally
Reader.Free;
end;

APos := Pos( 'unit ' + UnitName, Module );
if APos > 0 then
begin
try
InsertText := '';
AssignFile( F, VCSConfig.HeaderFileLocation );
Reset( F );
while not EOF(F) do
begin
Readln( F, Tmp );
InsertText := InsertText + #13 + #10 + Tmp;
end;
CloseFile(F);

InsertText := InsertText + #13 + #10;

Writer := CreateWriter;
try
Writer.CopyTo( APos - 1 );
Writer.Insert( PChar( InsertText ));
finally
Writer.Free;
end;
except
On E : EStreamError do
MessageDlg( 'Не могу создать шапку', mtInformation, [mbOK], 0 );
end;
end;

end;
{ *********************   Конец TIVCSModuleInterface  ************************** }
end.

- Jim Poe [001061]


Зависание Delphi 4(5)

Сергей Сахаров советует:

Delphi 4(5) виснут при запуске. Видеокарта S3 Virge.
Решение:

Добавьте в реестр строку:

[HKEY_CURRENT_CONFIG\Display\Settings]
"BusThrottle"="on"
Если не помогает, то попробуйте добавить в system.ini:
[Display]
"BusThrottle"="On"
Эта проблема устранена в Delphi 4sp3. [001066]


Delphi 2

Ошибка 1157 cmplib32.dll

Cannot open c:\delphi 2.0\bin\cmplib32.dll Error code 1157 (Не могу открыть c:\delphi 2.0\bin\cmplib32.dll, код ошибки 1157).

Что за ошибка такая с кодом 1157? Я пробовал удалить все DCU-файлы и переустановить PAS- и DFM-файлы, но ошибка не исчезла. Как это исправить?

Убедитесь в том, что все требуемые DLL находятся в search-пути.

- Mike Orriss [001095]


Delphi 1

2% ресурсов, в режиме редактирования

Если у вас открыты все формы (показаны или минимизированы), а в редакторе кода открыты все модули, ресурсы очень быстро исчерпываются. Попробуйте закрыть все формы и модули, и открыть только те, которыми вы будете пользоваться. В противном случае при компиляции вы можете завесить Delphi и саму машину. [001432]


Delphi 2

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

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

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

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

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

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

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

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

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

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

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

[001434]


Delphi 3

Описание типов файлов для Delphi

Формат .CAB-файлов

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

Формат .LIC-файлов

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

Формат .INF-файлов

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

Формат .dpr-файлов

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

Формат .pas-файлов

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

Формат .dfm-файлов

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

Формат .DOF-файлов

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

Формат .DSK-файлов

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

Формат .DPK-файлов

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

Формат .DCP-файлов

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

Формат .DPL-файла

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

Формат .DCI-файла

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

Формат .DCT-файла

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

Формат .TLB-файла

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

Формат .DRO-файла

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

Формат .RES-файла

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

Формат .DB-файла

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

Формат .DBF-файла

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

Фомат .GDB-файла

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

Формат .DMT-файла

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

Формат .DBI-файла

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

Формат .DEM-файла

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

Формат .OCX-файла

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


Delphi 1

Определение работы Delphi III

function DelphiLoaded : boolean;
{ Определение работающей Delphi. Во всяком случае, дает правильный результат если Delphi минимизирован, или имеет открытый проект. Также, правильный результат получается, если вызывающее приложение автономно, или запущено из-под IDE. Код написан на основе идей Wade Tatman wtatman@onramp.net - Mike O'Hanlon, The Pascal Factory, найденных в Delphi-Talk List. }

function WindowExists(ClassName, WindowName: string): boolean;
{ Проверяем наличие определенного окна Window, используя для этого паскалевские строки вместо PChars. }
var
PClassName, PWindowName: PChar;
AClassName, AWindowName: array[0..63] of char;
begin
if ClassName = ''
then PClassName := nil
else PClassName := StrPCopy(@AClassName[0], ClassName);
if WindowName = ''
then PWindowName := nil
else PWindowName := StrPCopy(@AWindowName[0], WindowName);
if FindWindow(PClassName, PWindowName) <> 0
then WindowExists := true
else WindowExists := false;
end;  {WindowExists}

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

Следующая программа возвращает TRUE при запуске в Delphi IDE (ПРИМЕЧАНИЕ: это _не_ сработает, если подпрограмма в DLL).

function InIDE: Boolean;
begin
Result := Bool(PrefixSeg) and
Bool(PWordArray(MemL[DSeg:36])^[8]));
end;  { InIDE }

[001442]


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

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

function LaunchedFromDelphiIDE: Boolean;
{----------------------------------------------------------------}
{ Осуществляем проверку запущенности приложения из-под Delphi    }
{ IDE. Идея взята из сообщения в Delphi-Talk от Ed Salgado       }
{ из Eminent Domain Software.                                    }
{----------------------------------------------------------------}
begin
LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL} and
Bool(PWordArray(MemL[DSeg:36])^[8]);
end; {LaunchedFromDelphiIDE}

function DelphiLoaded: Boolean;
{----------------------------------------------------------------}
{ Проверяем, загружена ли Delphi. Дает правильные результаты     }
{  - если вызывающее приложение запущено отдельно, или из-под IDE}
{  - если Delphi имеет открытый проект                           }
{  - если Delphi минимизирована.                                 }
{ Автор идеи Wade Tatman (wtatman@onramp.net).                   }
{----------------------------------------------------------------}
begin
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder',      'Menu Designer') then
if WindowExists('TAppBuilder',      '(AnyName)') then
if WindowExists('TApplication',    'Delphi') then
if WindowExists('TAlignPalette',  'Align') then
DelphiLoaded := true;
end;  {DelphiLoaded}

function DelphiInstalled: Boolean;
{----------------------------------------------------------------}
{ Проверяем наличие Delphi.ini, ищем в нем путь к Библиотеке     }
{ Компонентов, после чего проверяем ее наличие по этому пути.    }
{----------------------------------------------------------------}
var
IniFile: string;
begin
DelphiInstalled := false;
IniFile := WindowsDirectory + '\Delphi.ini';
if FileExists(IniFile) then
if FileExists(GetIni(IniFile, 'Library', 'ComponentLibrary'))
then DelphiInstalled := true;
end; {DelphiInstalled}

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

function WindowExists (WindowClass, WindowName: string): Boolean;
{----------------------------------------------------------------}
{ С помощью паскалевских строк проверяем наличие определенного   }
{ окна. Для поиска только имени окна (WindowName), используем    }
{ WindowClass '(AnyClass)'; для поиска только класса окна        }
{ (WindowClass), используем WindowName '(AnyName)'.              }
{----------------------------------------------------------------}
var
PWindowClass, PWindowName: PChar;
AWindowClass, AWindowName: array[0..63] of Char;
begin
if WindowClass = '(AnyClass)' then
PWindowClass := nil         else
PWindowClass := StrPCopy(PChar(@AWindowClass), WindowClass);

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

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

function WindowsDirectory: string;
{----------------------------------------------------------------}
{ Возвращаем путь к каталогу Windows (без обратной косой черты)  }
{----------------------------------------------------------------}
const
BufferSize = 144;
var
ABuffer: array[0..BufferSize] of Char;
begin
if GetWindowsDirectory(PChar(@ABuffer), BufferSize) = 0
then WindowsDirectory := ''
else WindowsDirectory := StrPas(PChar(@ABuffer));
end; {WindowsDirectory}

function GetIni (const IniFile, Section, Entry: string): string;
{----------------------------------------------------------------}
{ Получаем инициализационную 'profile' строку из определенного   }
{ пункта (Entry) определенной секции [Section] определенного     }
{ INI-файла (дополняем '.ini', если отсутствует). Возвращаем     }
{ нулевую строку, если IniFile, Section или Entry не найден.     }
{----------------------------------------------------------------}
var
IniFileVar: string;
IniFileObj: TIniFile;
begin
if StrEndsWith(IniFile, '.ini') then
IniFileVar := IniFile
else
IniFileVar := IniFile + '.ini';
IniFileObj := TIniFile.Create(IniFileVar);
GetIni := IniFileObj.ReadString(Section, Entry, '');
IniFileObj.Free;
end; {GetIni}

[001443]


Как исправить проблемы с вызовом помощи при одновременно стоящих Delphi 1 и Delphi 2?

Nomadic отвечает:

A: (AP): Решаются так...

В regedit убейте из секции HKLM\SOFTWARE\Microsoft\Windows\Help все, что равно "...\help".

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

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\AppPaths\
delphi32.exe] @="C:\\DELPHI2\\BIN\\delphi32.exe" "Path"="C:\\DELPHI2\\HELP"
[001486]


Каким именно релизом Delphi вообще стоит пользоваться для каждой конкретной версии?

Nomadic отвечает:

A: Во-первых, вы можете узнать точную версию Delphi, если в окошке Help | About нажмете кнопку Alt и, не отпуская, наберете "VERSION".

Delphi 1 следует апгрейдить до версии 1.02 с помощью патчей.

Delphi 2 следует апгрейдить до версии 2.01. Это полноценный дистрибутив. Эту версию можно, в частности, узнать по странице "Internet" в палитре компонентов. Ее точная версия 2.0.76.0.

Delphi 3 следует взять версии 3.02. Это полноценный дистрибутив 3.01 и патчи до 3.02.

Delphi 4 же должна быть обновлена вторым, а затем третьим Service Pack'ами, которые можно взять на сайте Inprise.

Версии Delphi 4.3 и 4.5 являются обманными версиями. В действительности это ранние беты Delphi 4.0. [001484]


Как поменять ширину и высоту IDE-редактора по-умолчанию?

Олегом Кулабухов отвечает:

Все соответсвующие значения находятся в реестре в следующих ключах

HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Editor
HKEY_CURRENT_USER\Software\Borland\Delphi\3.0\Editor
HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Editor
HKEY_CURRENT_USER\Software\Borland\C++Builder\1.0\Editor
В этих ключах находятся DefaultHeight DefaultWidth, определяющие высоту и ширину окна редактора соответственно. [001782]


Как перевести *.dfm в *.txt и обратно?

Олегом Кулабухов отвечает:

В каталоге с Дельфи есть соответствующая утилита.

\Delphi\convert enum.dfm enum.txt
\Delphi\convert enum.txt enum.dfm
[001824]


Борьба с SoftIce

Igor Nikolaev aKa The Sprite пишет:

Hаткнулся в инете на некий модуль StopIce, и любопытство сделало своё дело. Как долго я смеялся... :))))

Для тех, кто не в курсе: посмотрите export NmSymIsSoftIceLoaded (или что-то подобное) в nmtrans.dll.

Вот полный юнит против SOFTICE, при обнаружений отладчика перезагружает компьютер:

unit StopIce;

interface

implementation

uses Windows;

Function IsSoftIce95Loaded: boolean;
Var hFile: Thandle;
Begin
result := false;
hFile := CreateFileA('\\.\SICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;

Function IsSoftIceNTLoaded: boolean;
Var hFile: Thandle;
Begin
result := false;
hFile := CreateFileA('\\.\NTICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;

function WinExit(flags: integer): boolean;
function SetPrivilege(privilegeName: string; enable: boolean): boolean;
var tpPrev,
tp         : TTokenPrivileges;
token      : THandle;
dwRetLen   : DWord;
begin
result := False;
OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
token);
tp.PrivilegeCount := 1;
if LookupPrivilegeValue(nil, pchar(privilegeName), tp.Privileges[0].LUID)
then
begin
if enable then
tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
else
tp.Privileges[0].Attributes := 0;
dwRetLen := 0;
result := AdjustTokenPrivileges(token, False, tp, SizeOf(tpPrev), tpPrev,
dwRetLen);
end;
CloseHandle(token);
end;
begin
if SetPrivilege('SeShutdownPrivilege', true) then begin
ExitWindowsEx(flags, 0);
SetPrivilege('SeShutdownPrivilege', False)
end;
end;

initialization
if IsSoftIce95Loaded or IsSoftIceNTLoaded then begin
WinExit(EWX_SHUTDOWN or EWX_FORCE);
Halt;
end;
end.

[001347]


Не могу открыть файл помощи...

Я создал файл помощи для моего приложения и назвал его KidsHelp.hlp

При запуске в системе, в которой файл был создан, программа находит его без проблем. Данная машина имеет конфигурацию Pentium 120 с установленной Windows 95. При запуске программы на второй системе, с Windows 3.1, при выборе пункта меню "Using Help" программа не может открыть файл. Я создал файл помощи с помощью программы "HC31.exe". В самом проекте я не указывал полный путь к файлу помощи, я указал только его имя.

Для решения этой проблемы я делаю две вещи:

  1. Всегда располагаю файл помощи в том же каталоге, что и приложение
  2. Назначаю файл помощи в обработчике события главной формы OnCreate таким образом:

    Application.HelpFile := ChangeFileExt(Application.ExeName, '.HLP');

- Neil Rubenking [001101]


Как сделать так, чтобы в приложении вызывался хелп с окошечком для поиска раздела?

Nomadic советует:

  1. unit {$IFDEF WIN32} Windows {$ELSE} WinProcs {$ENDIF};

    function WinHelp(Wnd: HWnd; HelpFile: PChar; Command: Word; Data: LongInt): Bool;

    Здесь цитата из WinAPI Help:

    HELP_CONTEXTPOPUP
An unsigned long integer containing the context number for a topic.
Displays in a pop-up window a particular Help topic identified by a context
number that has been defined in the [MAP] section of the .HPJ file.
  2. То же самое, что делает макрос "Search()" для WinHelp-а.

    procedure TForm1.HelpSearchFor;
    var
    S: String;
    begin
    S := '';
    Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
    Application.HelpCommand( HELP_PARTIALKEY, LongInt( @S ) );
    end;

[001206]


Как заставить Help-файлы нормально отображать русский текст под Windows 3.x?

Nomadic советует:

Удалось вылечить дописыванием в файл пpоекта в гpафу Options стpочки FORCEFONT=Arial Cyr, пpичем HC31 pугается что нет такого шpифта, но зато хелп потом ноpмально показывается пpактически под любой pуссифициpованной виндой.

Пpовеpял с [Win31+CyrWin], [Win311Rus], [Win95PE], [Win95Rus].

На NT не пpовеpял.

Пpичем шpифты в тексте ноpмально пеpеключаются и будут не только Arial.

Вот кусок котоpый надо вставить в HPJ файл пеpед компиляцией -

[OPTIONS]
FORCEFONT=Arial Cyr
[001208]


256-цветное изображение из res-файла

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

function LoadBitmap256( hInstance: HWND; lpBitmapName: PChar ): HBITMAP;
var
hPal, hRes, hResInfo: THandle;
pBitmap: PBitmapInfo;
nColorData: Integer;
pPalette: PLogPalette;
X: Integer;
hPalette: THandle;
begin

hResInfo     := FindResource( hInstance, lpBitmapName, RT_BITMAP );
hRes         := LoadResource( hInstance, hResInfo );
pBitmap      := Lockresource( hRes );
nColorData   := pBitmap^.bmiHeader.biClrUsed;

hPal := GlobalAlloc( GMEM_MOVEABLE, ( 16 * nColorData ) );

{  hPal := GlobalAlloc( GMEM_MOVEABLE, ( SizeOf( LOGPALETTE ) +
(nColorData * SizeOf( PALETTEENTRY )));}
pPalette := GlobalLock( hPal );
pPalette^.palVersion := $300;
pPalette^.palNumEntries := nColorData;

for x := 0 to nColorData do begin
pPalette^.palPalentry[X].peRed   := pBitmap^.bmiColors[X].rgbRed;
pPalette^.palPalentry[X].peGreen := pBitmap^.bmiColors[X].rgbGreen;
pPalette^.palPalentry[X].peBlue  := pBitmap^.bmiColors[X].rgbBlue;
end;

hPalette := CreatePalette( pPalette^ );
GlobalUnlock( hRes );
GlobalUnlock( hPal );
GlobalFree( hPal );

end;

end.

- Mark Lussier [001047]


Как записать содержимое окна OpenGL в 'bmp' файл?

Nomadic советует:

Вот что попробовал - вроде получилось:

bt := TBitmap.Create;
bt.Width := gr.Width;
bt.Height := gr.Height;
bt.Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect);
bt.SaveToFile('e:\bt.bmp');
bt.Free;

(gr - объект, в канве которого я рисую с помощью OpenGL) [001108]


Как создать disable'ный битмап из обычного (emboss etc)?

Nomadic советует:

CreateMappedBitmap() :-)

Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из пpинципа:

  • все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
  • самые темные -> GetSysColor( COLOR_3DSHADOW );
  • нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );
Так на самом деле вот как делается данная задача:

procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
TmpImage,Monobmp:TBitmap;
IRect:TRect;
begin
MonoBmp := TBitmap.Create;
TmpImage:=Tbitmap.Create;
TmpImage.Width := bmpFrom.Width;
TmpImage.Height := bmpFrom.Height;
IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
TmpImage.Canvas.Brush.Color := clBtnFace;
try
with MonoBmp do
begin
Assign(bmpFrom);
Canvas.Brush.Color := clBlack;
if Monochrome then
begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with TmpImage.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBlack;
Font.Color := clWhite;
CopyMode := MergePaint;
Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
CopyMode := SrcAnd;
Draw(IRect.Left, IRect.Top, MonoBmp);
Brush.Color := clBtnShadow;
Font.Color := clBlack;
CopyMode := SrcPaint;
Draw(IRect.Left, IRect.Top, MonoBmp);
CopyMode := SrcCopy;
bmpTo.assign(TmpImage);
TmpImage.free;
end;
finally
MonoBmp.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
aaa(image1.picture.bitmap,image2.picture.bitmap);
Image2.invalidate;
end;

Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул).Hу а если уже совсем хорошо разобраться, то можно заметить функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.

Denis Tanayeff

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.

#define CO_GRAY 0x00C0C0C0L

hMemDC = CreateCompatibleDC(hDC);
hOldBitmap = SelectObject(hMemDC, hBits);

// hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled
{
hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, PATCOPY);
DeleteObject(SelectObject(hDC, hOldBrush));

lbLogBrush.lbStyle = BS_PATTERN;
lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

DeleteObject(SelectObject(hDC, hOldBrush));
DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);
}
[001129]


Компонент для работы с FLIC-анимацией

Новостная группа: comp.lang.pascal.delphi.components
Тема: Компонент для работы с FLIC-анимацией: отправной пункт.
От: Paul Kuczora <paul@kuczora.demon.co.uk>
Дата: Чет, 03 Авг 95 16:51:19 GMT

В качество ответа на целый круг вопросов, я включил в свой ответ два файла:

aaplay1.inc    - include-файл с интерфейсом для библиотеки aaplay.dll
aaplay1.pas    - сырой скелет компонента для проигрывания FLIC-анимации
Я разработал это глядя на другой компонент (это был полнофункциональный плейер, работающий как форма), и вынужден был сохранить некоторые вещи неприкосновенными (попробуй тут сделай иначе :-)

Для работы вам понадобится библиотека aaplay.dll от Autodesk, которую вы можете найти на множестве мест (например, я так предполагаю, на Encarta CD). Для полного счастья вы можете обратиться к файлу помощи для Animation Player for Windows, который, не удивляйтесь, содержит справку для этой DLL - на первой странице найдите в ее самой нижней части указание на эту библиотеку, и перед вами предстанет полная справка по вызовам этой самой DLL.

Надеюсь что помог вам. . .

ВНИМАНИЕ! Это мой первый код, написанный для Windows (спасибо Delphi), поэтому он рекомендуется только для ознакомления.

{ ============================================================================ }

{ aaplay1.inc }
{ (c) P W Kuczora }
{ 17-го апреля 1995 }

{ Заголовочный файл, содержащий константы и определения типов для aaplay1.pas }

 const
NULL = 0;
NULLPTR = ^0;

{
Доступные Флаги wMode: integer;
Используются в aaLoad, aaReLoad
Первые восемь бит wMode используются в aa_flags.
}
AA_MEMORYLOAD = $1;        { Загрузка в память }
AA_HIDEWINDOW = $2;        { Скрывать окно анимации }
AA_NOPALETTE = $4 ;        { Анимация без палитры }
AA_RESERVEPALETTE = $8;    { Резервировать при старте всю палитру }
AA_LOOPFRAME = $10;        { Циклическая загрузка кадров }
AA_FULLSCREEN = $20;       { Использовать полноэкранный режим воспроизведения }
AA_STOPNOTIFY = $40;       { Исключать любые уведомляющие сообщения }
AA_STOPSTATUS = $80;       { Исключать сообщения об изменении статуса }
AA_NOFAIL = $100;          { Уменьшение типа нагрузки при ошибке }
AA_DONTPAINT = $200;       { Не делать paByVal-анимацию при загрузке }
AA_BUILDSCRIPT = $400;     { lpzFileName - скрипт, не имя }
AA_ALLMODES = $FF;

{
Доступные флаги для режимов звука - wMode: integer;
Используются в aaSound
}

AA_SNDFREEZE = $1;         { Заморозка кадров при проигрывании звуков }
AA_SNDDEVICEID = $100;     { ID устройства, не имя }
AA_SNDBUILDALIAS = $200;   { создавать псевдоним звукового устройства }
{
aaNotify позволяет извещать приложение о проигрывании определенных
кадров.

lPosition - позиция, на которой должно происходить уведомление.

wParam для этого сообщения - hAa, а lParam копируется из этого вызова.

При установке сообщения возвращается TRUE.

Следующее значение определяет необходимость завершения цикла анимации
по окончании проигрывания звука. Если звук отсутствует, анимация
зацикливается навсегда.
}
AA_LOOPSOUND = $FFFF;

{
Автоматическое уведомление посылается при перезагрузке в скрипте
анимации.

lParam для этого сообщения определен ниже
}
AA_ANIMATIONLOADED = 0;

{
Типы параметров
Используется с aaGetParm и aaSetParm.
}
AA_STATUS = 1;                      { Получить текущий статус }
AA_FILETYPE = 2;                    { Получить тип анимации на диске }
AA_MODE = 3;                        { Получить/установить флаги анимации }
AA_WINDOW = 4;                      { Установить/получить окно анимации }
AA_SPEED = 5;                       { Установить/получить текущую скорость }
AA_DESIGNSPEED = 6;                 { Получить скорость на этапе дизайна }
AA_FRAMES = 7;                      { Получить число кадров }
AA_POSITION = 8;                    { Установить/получить позицию текущего кадра }
AA_LOOPS = 9;                       { Установить/получить число циклов }
AA_X = 10;                          { Установить/получить позицию выводимого окна }
AA_Y = 11;                          { Установить/получить позицию выводимого окна }
AA_CX = 12;                         { Установить/получить размеры выводимого окна }
AA_CY = 13;                         { Установить/получить размеры выводимого окна }
AA_ORGX = 14;                       { Установить/получить начало выводимого окна }
AA_ORGY = 15;                       { Установить/получить начало выводимого окна }
AA_WIDTH = 16;                      { Получить ширину анимации }
AA_HEIGHT = 17;                     { Получить высоту анимации }
AA_RPTSOUND = 18;                   { Установить/получить повторения звуков }
AA_PAUSE = 19;                      { Установить/получить время паузы }
AA_DELAYSND = 20;                   { Установить/получить время задержки звука }
AA_TRANSIN = 21;                    { Установить/получить тип входного перехода }
AA_TRANSOUT = 22;                   { Установить/получить тип выходного перехода }
AA_TIMEIN = 23;                     { Установить/получить время входного перехода }
AA_TIMEOUT = 24;                    { Установить/получить время выходного перехода }
AA_CALLBACK = 25;                   { Установить/получить окно обратного вызова }
AA_ANIMWND = 26;                    { Получить дескриптор окна анимации }
AA_MODFLAG = 100;                   { Установить/получить флаг изменения скрипта }
AA_SCRIPTNAME = 101;                { Установить/получить имя скрипта }
AA_ANIMATION = 102;                 { Получить/установить скрипт анимации }
AA_ANIMATIONCOUNT = 103;            { Получить счетчик скрипта анимации }
AA_SCRIPTCONTENTS = 104;            { Получить содержание скрипта }
AA_LASTERROR = 1001;                { Получить код последней ошибки }
AA_LASTERRORMESSAGE = 1002;         { Получить/установить сообщение о последней ошибке }

{
Типы параметров
Используется с aaSetParmIndirect
}
AA_SETMODE = $1;                  { Получить/установить флаги анимации }
AA_SETWINDOW = $2;                { Установить/получить окно анимации }
AA_SETSPEED = $4;                 { Установить/получить текущую скорость }
AA_SETPOSITION = $8;              { Установить/получить позицию текущего кадра }
AA_SETLOOPS = $10;                { Установить/получить число циклов }
AA_SETX = $20;                    { Установить/получить левую координату выводимого окна }
AA_SETY = $40;                    { Установить/получить левую координату выводимого окна }
AA_SETCX = $80;                   { Установить/получить верхнюю координату выводимого окна }
AA_SETCY = $100;                  { Установить/получить верхнюю координату выводимого окна }
AA_SETORGX = $200;                { Установить/получить ширину выводимого окна }
AA_SETORGY = $400;                { Установить/получить ширину выводимого окна }
AA_SETRPTSOUND = $800;            { Установить/получить повторения звуков }
AA_SETPAUSE = $1000;              { Установить/получить время паузы }
AA_SETDELAYSND = $2000;           { Установить/получить время задержки звука }
AA_SETTRANSIN = $4000;            { Установить/получить тип входного перехода }
AA_SETTRANSOUT = $8000;           { Установить/получить тип выходного перехода }
AA_SETTIMEIN = $10000;            { Установить/получить время входного перехода }
AA_SETTIMEOUT = $20000;           { Установить/получить время выходного перехода }
AA_SETCALLBACK = $40000;          { Установить/получить окно обратного вызова }
AA_ALL = $FFFFFFFF;               { Получить/установить все параметры }

{
Значения статуса для анимации
}
AA_STOPPED = 1;             { Загружена, но не воспроизводится }
AA_QUEUED = 2;              { Анимация ожидает воспроизведение }
AA_PLAYING = 3;             { Анимация воспроизводится }
AA_PAUSED = 4;              { Анимация в режиме паузы }
AA_DONE = 5;                { Анимация закончила воспроизведение }
{ и ожидает вызов aaStop }

{
Определения типов файла
}
AA_FLI = $1;               { Формат Autodesk Animator Fli }
AA_DIB = $2;               { Формат Windows DIB }
AA_NUMTYPES = $2;          { Количество типов }
AA_SCRIPT = $3;            { Скрипт без анимации }

{
Типы переходов
}
AA_CUT = 0;                { Простая остановка одной и запуск другой }
AA_FADEBLACK = $1;         { Уход/выход из черного }
AA_FADEWHITE = $2;         { Уход/выход из белого }

{
Коды ошибок, возвращаемые aaGetParm(xxx, AA_LASTERROR)
}
AA_ERR_NOERROR = 0;        {  Неизвестная ошибка  }

AA_ERR_NOMEMORY = $100;    {  256 - Ошибка нехватки памяти }
AA_ERR_BADHANDLE = $101;   {  257 - Плохой дескриптор }
AA_ERR_NOTIMERS = $102;    {  258 - Невозможно запустить таймер }
AA_ERR_BADSOUND = $103;    {  259 - Плохое звуковое сопровождение }
AA_ERR_NOSCRIPT = $104;    {  260 - Требуется скрипт }
AA_ERR_WRITEERR = $105;    {  261 - Ошибка записи (для сценария) }
AA_ERR_BADANIMATION = $106;  {  262 - Невозможно открыть анимацию }

AA_ERR_BADWINDOWHANDLE = $200;     {  512 - Плохой дескриптор окна }
AA_ERR_WINDOWCREATE = $201;        {  513 - Невозможно создать окно }
AA_ERR_DLGERROR = $202;            {  514 - Ошибка диалога }

AA_ERR_INVALIDSTATUS = $300;       {  768 - Неверный статус }
AA_ERR_BADDIBFORMAT = $301;        {  769 - Плохой dib-файл }
AA_ERR_BADFLIFORMAT = $302;        {  770 - Плохой fli-файл }
AA_ERR_UNRECOGNIZEDFORMAT = $303;  {  771 - Нераспознанный формат }
AA_ERR_NOSOUND = $304;             {  772 - Звук не поддерживается }
AA_ERR_NOTVALIDFORSCRIPTS = $305;  {  773 - Неправильный сценарий }
AA_ERR_INVALIDFILE = $306;         {  774 - Плохой дескриптор файла }
AA_ERR_NOSCRIPTS = $307;           {  775 - Нет файлов-скриптов }

AA_ERR_SPEED = $400;            {  1024 - Неверная скорость  }
AA_ERR_LOOPS = $401;            {  1025 - Неверные циклы }
AA_ERR_RPTSOUND = $402;         {  1026 - Неверный повтор звука }
AA_ERR_PAUSE = $403;            {  1027 - Неверная пауза }
AA_ERR_TRANSIN = $404;          {  1028 - Неверный переход }
AA_ERR_TIMEIN = $405;           {  1029 - Неверный переход }
AA_ERR_TRANSOUT = $406;         {  1030 - Неверное время перехода }
AA_ERR_TIMEOUT = $407;          {  1031 - Неверное время перехода }
AA_ERR_DELAYSND = $408;         {  1032 - Неверная задержка звука }
AA_ERR_INVALIDTYPE = $409;      {  1033 - Неверный тип параметра }

AA_ERR_DUPLICATENOTIFY = $500;     {  1280 - Дублирование уведомления }

AA_ERR_NOSWITCH = $600;          {  1536 - Отсутствие ключей в скрипте }
AA_ERR_PARSELOOPS = $601;        {  1537 - Плохие циклы в скрипте }
AA_ERR_PARSESPEED = $602;        {  1538 - Плохая скорость в скрипте }
AA_ERR_BADRPTSOUND = $603;       {  1539 - Плохое повторение звука в скрипте }
AA_ERR_PARSEPAUSE = $604;        {  1540 - Плохая пауза в скрипте }
AA_ERR_PARSETRANS = $605;        {  1541 - Плохой переход в скрипте }
AA_ERR_PARSEDELAYSND = $606;     {  1542 - Плохая задержка звука в скрипте }
AA_ERR_TOOMANYLINKS = $607;      {  1543 - Слишком много ссылок }

{
dwFlags: integer; может быть любым из нижеперечисленных
Используется в aaGetFile.
}
AA_GETFILE_MUSTEXIST = $1;
AA_GETFILE_NOSHOWSPEC = $2;
AA_GETFILE_SAVE = $4;
AA_GETFILE_OPEN = $8;
AA_GETFILE_USEDIR = $10;
AA_GETFILE_USEFILE = $20;
AA_GETFILE_SOUND = $40;
AA_GETFILE_SCRIPT = $80;
AA_GETFILE_ANIMATION = $100;

{
wMode: integer; Значения
Используется в aaSave
}
AA_SAVE_IFMODIFIED = $1;
AA_SAVE_AS = $2;
AA_SAVE_CANCEL = $4;

{
Возможности
Используется в aaGetCaps
}
AA_CAP_TIMER = 1;
AA_CAP_SOUND = 2;
AA_CAP_SCRIPT = 3;

{
Статусные сообщения анимации
Используйте RegisterWindowMessage для получения номеров реальных сообщений.
}
AA_NOTIFY = 'AAPLAY Уведомление';   { Сообщение-уведомление }
AA_STOP = 'AAPLAY Стоп';            { Стоп-сообщение }

{
Это посылается в первом слове lParam с сообщением AA_ERROR.
Это указывает на возникшую ошибку
}
AA_BADPLAY = 1;             { Ошибка при попытке воспроизведения }
AA_BADNOTIFY = 2;           { Ошибка при попытке послать уведомление }
AA_BADSCRIPT = 3;           { Ошибка в сценарии при попытке }
{ воспроизведения }

{ ========================================================================== }

unit aaplay1;
{ (c) P W Kuczora }
{ 27-го апреля 1995 }
interface

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

{$I AAPLAY1.INC}

const
AAPARMS_SIZE = 54;

type
AAHandle = word;                            { Дескриптор анимации }
AASPEED = word;                             { Тип, содержащий скорость анимации }
AATRN = word;                               { Тип для хранения перехода анимации }
dword = longint;

{
Структура параметра должна быть использована для анимации.
}
AAPARMS = record
AA_STATUS           : byte;        {  Текущий статус анимации }
AA_FILETYPE         : byte;        {  Тип файла на диске }
AA_MODE             : byte;        {  Некоторые флаги }
AA_bitpix           : byte;        {  бит на пиксел }

AA_HWnd             : HWnd;         {  Дескриптор окна для статусного сообщения }
AA_X                : integer;      {  Левая координата выводимого окна }
AA_Y                : integer;      {  Верхняя координата выводимого окна }
AA_CX               : integer;      {  Ширина выводимого окна }
AA_CY               : integer;      {  Высота выводимого окна }
AA_ORGX             : integer;      {  PoByVal в показываемой анимации }
AA_ORGY             : integer;      {  в верхнем левом углу }

AA_SPEED            : AASPEED;      {  Скорость анимации в миллисекундах на кадр }
AA_DESIGNSPEED      : AASPEED;      {  Проектируемые миллисекунды на кадр }

AA_WIDTH            : word;         {  Ширина анимации в пикселах }
AA_HEIGHT           : word;         {  Высота анимации в пикселах }

AA_FRAMES           : word;         {  Количество кадров в анимации }

AA_POSITION         : dword;        {  Текущая кадровая позиция }
AA_LOOPS            : dword;        {  Конечная позиция анимации }
AA_RPTSOUND         : word;         {  Количество повторов звука }
AA_PAUSE            : word;         {  Количество миллисекунд замораживания кадра }
AA_DELAYSND         : longint;      {  Задержка звука в миллисекундах }
AA_TRANSIN          : byte;         {  Переход в начале анимации }
AA_TRANSOUT         : byte;         {  Переход в конце анимации }
AA_TIMEIN           : word;         {  Продолжительность входного перехода в миллисекундах }
AA_TIMEOUT          : word;         {  Продолжительность выходного перехода в миллисекундах }
AA_CALLBACK         : HWnd;         {  Сообщение окна обратного вызова }
AA_ANIMWND          : Hwnd;         {  Дескриптор окна анимации }
end;

AAPARMSPtr = ^AAPARMS;

{type}
TAAPlayer = class(TMediaPlayer)
procedure OpenAA;

private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
AAParameters: AAPARMS;
FlicHandle: AAHandle;
PlayWinHandle: THandle;
StatusWinHandle: THandle;
CallbackWinHandle: THandle;
published
{ Published declarations }
end;

procedure Register;

{ Внешние вызовы AAPLAY.DLL }

function aaOpen : boolean;
procedure aaClose;
function aaGetCaps(wType: word) : word;
function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word;
x, y, wid, hght, orgx, orgy: integer): AAHandle;
function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word)
: boolean;
function aaUnload(hAa: AAHandle): boolean;
function aaPlay(hAa: AAHandle) : boolean;
function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean;
function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word;
function aaStop(hAa: AAHandle) : boolean;
function aaPause(hAa: AAHandle) : boolean;
function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean;
function aaGetParm(hAa: AAHandle; wType: word) : longint;
function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word)
: boolean;
function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint)
: AAHandle;
function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr;
wMask: word): boolean;
function aaShow(hAa: AAHandle; bShow: boolean) : boolean;
function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word)
: boolean;
function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word;
lpszDriver: PChar; wDrvLen: word) : integer;
function aaSave(hAa: AAHandle; wMode: word) : integer;

implementation

{ =========================================================================== }
procedure Register;
begin
RegisterComponents('Samples', [TAAPlayer]);
end;

{ --------------------------------------------------------------------------- }
procedure TAAPlayer.OpenAA;

var
FileSuffix, tempstr: string[12];
a,b: integer;

begin
{     tempstr := ExtractFilename(AAPlayer.Filename); }
{     a := StrPos(tempstr,'.');

if (a > 0) then
begin
b := a;

while (b <= StrLen(tmpstr)) do
begin
FileSuffix := FileSuffix + StrUpper(tempstr[b]);
b := b+1;
end;

if ((FileSuffix = '.FLC') or (FileSuffix = '.FLI')) then
begin}
{          AutoEnable := False;
EnabledButtons := [btRecord,btEject];
}           {end;

end;
}
 end;

{ =========================================================================== }
{ Внешние вызовы 'AAPLAY.DLL' }
{$F+}
{ =========================================================================== }

{ --------------------------------------------------------------------------- }
 function aaOpen : boolean;
external 'AAPLAY';

{ --------------------------------------------------------------------------- }
 procedure aaClose;
external 'AAPLAY';
{
'  AAOpen и AAClose в действительности не нужны, за исключением обработки
'  ошибки в Windows, которая предохраняет освобождение библиотек в процедуре
'  выхода Windows (Windows Exit Proc, WEP).
'
'  Поэтому мы используем AAClose для освобождения библиотек при закрытии
'  последней задачей AAPlay DLL.
}

{ --------------------------------------------------------------------------- }
 function aaGetCaps(wType: word) : word;
external 'AAPLAY';
{
'  Получение возможностей
}
{ --------------------------------------------------------------------------- }
 function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word;
x, y, wid, hght, orgx, orgy: integer): AAHandle;
external 'AAPLAY';
{
'  aaLoad загружает анимацию.
'
'  Имя файла в lpzFileName
'  и режим загрузки в wMode.
}

{ --------------------------------------------------------------------------- }
 function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word)
: boolean;
external 'AAPLAY';
{
'  aaReLoad загружает файл новый анимации
'  "в дескриптор" старой анимации.
'
'  Уведомления теряются, но палитра и окно
'  сохраняются.
}

{ --------------------------------------------------------------------------- }
 function aaUnload(hAa: AAHandle): boolean;
external 'AAPLAY';
{
'  aaUnload выгружает загруженную анимацию.
'
'  Возвращается FALSE, если
'  hAa не является дескриптором загруженной анимации.
}

{ --------------------------------------------------------------------------- }
 function aaPlay(hAa: AAHandle) : boolean;
external 'AAPLAY';
{
'  aaPlay воспроизводит загруженную анимацию.
'
'  Возвращается TRUE, если после возврата aaPlay анимация не останавливается.
}

{ --------------------------------------------------------------------------- }
 function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean;
external 'AAPLAY';
{
'  aaNotify позволяет извещать приложение о воспроизведении
'  определенных кадров анимации.
'
'  lPosition -позиция, в которой должно происходить уведомление.
'
'  wParam для данного сообщения - hAa, а lParam копируется из этого вызова.
'
'  Возвращается TRUE, если уведомление установлено.
}

{ --------------------------------------------------------------------------- }
 function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word;
external 'AAPLAY';
{
'  aaCancel позволяет приложению отменить уведомления, установленные aaNotify.
'
'  lLoPos и lHiPos задает верхний и нижний предел позициям.
'
'  Возвращает количество отмененных уведомлений.
}

{ --------------------------------------------------------------------------- }
 function aaStop(hAa: AAHandle) : boolean;
external 'AAPLAY';
{
'  aaStop прекращает воспроизведение анимации.
'
'  При остановке воспроизведения aaStop возвращает TRUE.
}

{ --------------------------------------------------------------------------- }
 function aaPause(hAa: AAHandle) : boolean;
external 'AAPLAY';
{
'  aaPause приостанавливает воспроизведение.
'
'  Возвращается TRUE, если после возврата aaPause анимация переходит в режим паузы.
'
'  Для продолжения воспроизведения анимации используйте aaPlay.
}

{ --------------------------------------------------------------------------- }
 function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean;
external 'AAPLAY';
{
'  aaPrompt позволяет выводить диалог для получения данных от пользователя.
'
'  При получении данных дескриптор меняется, и, таким образом, вступают
'  в силу новые параметры. Старый дескриптор не уничтожается до тех пор,
'  пока не будет создан новый.
'
'  Если новый дескриптор не может быть создан, aaPrompt возвращает NULL,
'  в противном случае возвращается новый дескриптор.
}

{ --------------------------------------------------------------------------- }
 function aaGetParm(hAa: AAHandle; wType: word) : longint;
external 'AAPLAY';
{
'  aaGetParm возвращает информацию об анимации.
'
'  Некоторая информация может быть установлена с помощью aaSetParm,
'  и другая информация - информация о состоянии, поддерживаемая AAPLAY.
}

{ --------------------------------------------------------------------------- }
 function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word)
: boolean;
external 'AAPLAY';
{
'  aaGetParmIndirect возвращает ту же информацию, что и aaGetParm,
'  в структуре, удобной для легкого доступа из приложений Visual Basic.
}

{ --------------------------------------------------------------------------- }
 function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint)
: AAHandle;
external 'AAPLAY';
{
'  aaSetParm устанавливает информацию для анимации
}

{ --------------------------------------------------------------------------- }
 function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr;
wMask: word): boolean;
external 'AAPLAY';
{
'  aaSetParmIndirect устанавливает параметры анимации из структуры.
}

{ --------------------------------------------------------------------------- }
 function aaShow(hAa: AAHandle; bShow: boolean) : boolean;
external 'AAPLAY';
{
'  aaShow позволяет показать в окне отдельный кадр анимации.
'
'  Mode определяет способ рисования анимации.
'
'  Параметры окна возможно задать с помощью aaSetParm или aaSetParmIndirect.
'
'  aaShow возвращает TRUE, если анимация была отрисована без ошибок.
}

{ --------------------------------------------------------------------------- }
 function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word)
: boolean;
external 'AAPLAY';
{
'  aaSound открывает и закрывает канал звукового сопровождения анимации.
'
'  Звуковой канал будет открыт, если аргумент file не будет равен null
'  и не будет пустым, в противном случае канал будет закрыт.
'
'  Если устройство равно null, то для выбора подходящего устройства
'  используется формат файла.
}

{ --------------------------------------------------------------------------- }
 function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word;
lpszDriver: PChar; wDrvLen: word) : integer;
external 'AAPLAY';
{
' Открывает системного диалоговое окно стандартного типа ("открыть файл"),
' предлагающее пользователю выбрать файл.
'
' <dwFlags> определяет характеристики диалогового окна.
' Список возможных флагов:
'       AA_GETFILE_MUSTEXIST    Выбранный файл должен удовлетворять условиям
'                               флагов OpenFile(), в противном случае диалог
'                               издаст системный звук.
'       AA_GETFILE_NOSHOWSPEC   НЕ показывать путь в поле редактирования.
'                               По умолчанию путь к файлу показывается.
'       AA_GETFILE_SAVE         Кнопка Ok имеет заголовок "Save".
'       AA_GETFILE_OPEN         Кнопка Ok имеет заголовок "Open".
'       AA_GETFILE_USEFILE      Взять имя файла из параметра lpszPath
'       AA_GETFILE_UDEDIR       Взять каталог из параметра lpszPath
'       AA_GETFILE_SOUND        Получить звуковой файл и драйвер
'       AA_GETFILE_SCRIPT       Получить файл со скриптом
'       AA_GETFILE_ANIMATION    Получить файл анимации (без скриптов)
'
' <lpszPath> - строковый буфер LPSTR, куда после выполнения диалога
' пишется полное имя пути.
' <wBufLen> - длина данного буфера.
'
' <lpszDriver> - строковый буфер LPSTR для хранения выбранного
' звукового устройства.
' <wDrvLen> - длина данного буфера.
'
' Возвращаемые значения: 0, если была нажата кнопка Cancel
'                        -1, если OpenFile() потерпело неудачу,
'                        а AA_GETFILE_MUSTEXIST не определен.
'                        В противном случае возвращается дескриптор DOS-файла.
'                        При возврате из aaOpenFile данный дескриптор "не открыт".
}

{ --------------------------------------------------------------------------- }
 function aaSave(hAa: AAHandle; wMode: word) : integer;
external 'AAPLAY';
{
'  Сохранение скрипта
}

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

{$F-}
{ Окончание внешних вызовов 'AAPLAY.DLL' }
{ =========================================================================== }

 end.

{ =========================================================================== }

Dr Paul Kuczora.

--------------------------------------------------------------------------------
Paul Kuczora c home.london.uk
(на создание файла потрачен один день) [001137]


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

Nomadic советует:

Надо обpабатывать сообщение CM_HITTEST (Это сообщение получают даже потомки от TGraphicsControl, не имеющего своего HWND).

Hапpимеp, так:

procedure TLine.CMHitTest(var Message: TWMNCHitTest);
begin
if PointInLineReg(Message.XPos, Message.YPos) then
begin
Message.Result := 1;
end
else
begin
 Message.Result := 0;
end;
end;

Для органов управления Windows, если Вы не используете VCL, требуется обрабатывать сообщение WM_NCHITTEST. [001172]


Как быстро нарисовать тень в заданном регионе?

Nomadic советует:

procedure TForm2.DrawShadows(WDepth, HDepth : Integer);
var
Dst, RgnBox : TRect;
hOldDC : HDC;
OffScreen : TBitmap;
Pattern : TBitmap;
Bits : array[0..7] of WORD;
begin
Bits[0] := $0055;
Bits[1] := $00aa;
Bits[2] := $0055;
Bits[3] := $00aa;
Bits[4] := $0055;
Bits[5] := $00aa;
Bits[6] := $0055;
Bits[7] := $00aa;

hOldDC := Canvas.Handle;
Canvas.Handle := GetWindowDC(Form1.Handle);

OffsetRgn(ShadeRgn, WDepth, HDepth);
GetRgnBox(ShadeRgn, RgnBox);

Pattern := TBitmap.Create;
Pattern.ReleaseHandle;
Pattern.Handle := CreateBitmap(8, 8, 1, 1, @(Bits[0]));
Canvas.Brush.Bitmap := Pattern;

OffScreen := TBitmap.Create;
OffScreen.Width := RgnBox.Right-RgnBox.Left;
OffScreen.Height := RgnBox.Bottom-RgnBox.Top;
Dst := Rect(0, 0, OffScreen.Width, OffScreen.Height);

OffsetRgn(ShadeRgn, 0, -RgnBox.Top);
FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);
OffsetRgn(ShadeRgn, 0, RgnBox.Top);

// BitBlt работает быстрее CopyRect
BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height,
Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND);

Canvas.Brush.Color := clBlack;
FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);

BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width,
OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT);

OffScreen.Free;
Pattern.Free;
OffsetRgn(ShadeRgn, -WDepth, -HDepth);

ReleaseDC(Form1.Handle, Canvas.Handle);
Canvas.Handle := hOldDC;
end;

Комментарии :
Функция рисует тень сложной формы на форме Form2 (извиняюсь за стиль). Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API. [001177]


Как рисовать на органе управления, например, на TPanel?

Nomadic советует:

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.

{ Example. We recommend You to create this component through Component Wizard.
In Delphi 1 it can be found as 'File|New Component...', and can be found
as 'Component|New Component...' in Delphi 2 or above. }
 type
TcPanel = class(TPanel)
public
property Canvas;
end;

У меня есть маленькое замечание.

Если у объекта нет свойства Canvas (у TDBEdit вpоде-бы нет), то, по кpайней меpе в D3, можно использовать класс TControlCanvas. Пpимеpное использование:

var
cc: TControlCanvas;
...
cc := TControlCanvas.Create;
cc.Control := yourControl;
...

и далее как обычно можно использовать методы Canvas. [001185]


Как мне из Handle битовой картинки, получить адрес битового изображения в памяти?

Nomadic советует:

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

Сразу оговорюсь, что все это работает только под Win95/NT.

type
TarrRGBTriple=array[byte] of TRGBTriple;
ParrRGBTriple=^TarrRGBTriple;

{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var
DC:HDC;
begin
if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}
BM:=0;
PB:=nil;
fillchar(BI,sizeof(BI),0);
with BI.bmiHeader do {заполняем структуру с параметрами битмэпа}
begin
biSize:=sizeof(BI.bmiHeader);
biWidth:=SX;
biHeight:=SY;
biPlanes:=1;
biBitCount:=24;
biCompression:=BI_RGB;
biSizeImage:=0;
biXPelsPerMeter:=0;
biYPelsPerMeter:=0;
biClrUsed:=0;
biClrImportant:=0;

FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}

if (biWidth or biHeight)<>0 then
begin
DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу
разместить выделяемый битмэп в спроецированном файле, что позволяет
ускорять работу и экономить память при генерировании большого битмэпа}
{!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}
if BM=0 then Error('error creating DIB');
end;
end;
end;

{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var
HF:integer; {file handle}
HM:THandle; {file-mapping handle}
PF:pchar; {pointer to file view in memory}
i,j: integer;
Ofs:integer;
begin
{открываем файл}
HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);
if HF<0 then Error('open file '''+FileName+'''');
try
{создаем объект-проецируемый файл}
HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
if HM=0 then Error('can''t create file mapping');
try
{собственно проецируем объект в адресное }
PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
if PF=nil then Error('can''t create map view of file');
try
{работаем с файлом как с областью памяти через указатель PF}
if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format');
Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do
begin
if (biSize<>40) or (biPlanes<>1) then Error('file format');
if (biCompression<>BI_RGB) or
(biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
Allocate(biWidth,biHeight);
end;

for j:=0 to BI.bmiHeader.biHeight-1 do
for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
finally
UnmapViewOfFile(PF);
end;
finally
CloseHandle(HM);
end;
finally
FileClose(HF);
end;
end;

{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;
begin
if (X>=0) and (X<BI.bmiHeader.biWidth) and
(Y>=0) and (Y<BI.bmiHeader.biHeight)
then Result:=PRGB(PB+(Y)*FLineSize+X*3)
else Result:=PRGB(PB);
end;

Если у вас на форме есть компонент TImage, то можно сделать так:

var BMP:TMBitmap;
B:TBitmap;
...
BMP.LoadFromFile(..);
B:=TBitmap.Create;
B.Handle:=BMP.Handle;
Image1.Picture.Bitmap:=B;

и загруженный битмэп появится на экране. [001204]


Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?

Nomadic советует:

Надо сразу отметить, что для работы Microsoft OpenGL 1.1 требуется только наличие в системе двух динамических библиотек. Они различны для Windows 95 и для Windows NT. Они всегда инсталлируется вместе с системой, если эта система - Windows 95 OSR2 или более поздняя, или если это Windows NT. Однако, если Вы столкнулись с машиной, где OpenGL отсутствует (Windows 95 OSR1 и более ранние), то достаточно их взять из диcтpибyтива OSR2 (GLU32.DLL и OPENGL32.DLL) и записать в GetSystemDirectory - и запycкайте OpenGL-приложения на здоpовье.

Более эффективную реализацию OpenGL для Win32 от фирмы SGI я бы советовал стянуть с www.sgi.com или www.opengl.org (SGI OpenGL for Windows). Кроме того, оттуда же советую скачать дополнительную библиотеку функций-утилит, позволяющую упростить работу в OpenGL (GLUT). Возможно, что Вам понравится какой-нибудь API более высокого уровня, типа SCiTech MGL (www.scitechsoft.com). [001220]


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

Как вывести на экран текст с 'красивым' обрезанием по длине (если текст не помещается на экране)?

Nomadic советует:

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS. [001230]


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

При работе программ на Delphi 1 под Windows 95 в hicolor-режимах на иконках TBitBtn'ов обнаруживаются странные коричневые артефакты. Как от них избавиться?

Nomadic советует:

A: (AB): Залить фон битмапа синим цветом. [001494]


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

Получение контекста устройства для элемента управления

{Bitmap в TImage}
HDC := TImage.Picture.bitmap.canvas.handle;

DC - что нибудь с Canvas.handle. [001521]


Delphi 1

TCanvas и освобождение дескрипторов

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):

type
TWindowCanvas = class(TCanvas)
private
FWinControl: TWinControl;
FDeviceContext: HDC;
procedure SetWinControl(AControl: TWinControl);
protected
procedure CreateHandle; override;
public
destructor Destroy; override;
procedure FreeHandle;
property WinControl: TWinControl read FWinControl write SetWinControl;
end;

implementation

destructor TWindowCanvas.Destroy;
begin
FreeHandle;
inherited Destroy;
end;

procedure TWindowCanvas.CreateHandle;
begin
if FControl = nil then inherited CreateHandle else
begin
if FDeviceContext = 0 then
FDeviceContext := GetWindowDC(WinControl.Handle);
Handle := FDeviceContext;
end;
end;

procedure TControlCanvas.FreeHandle;
begin
if FDeviceContext <> 0 then
begin
Handle := 0;
ReleaseDC(WinControl.Handle, FDeviceContext);
FDeviceContext := 0;
end;
end;

procedure TControlCanvas.SetWinControl(AControl: TWinControl);
begin
if FWinControl <> AControl then
begin
FreeHandle;
FWinControl := AControl;
end;
end;

Очевидно, вы должны должны следить за ситуацией, и разрушать TWindowCanvas (или освобождать дескриптор) перед тем, как уничтожить элемент управления, связанный с ним. Также, имейте в виду, что дескриптор DeviceContext не освобождается автоматически после обработки каждого сообщения (как это происходит с дескрипторами TControlCanvas); для освобождения дескриптора вы должны явно вызвать FreeHandle (или разрушить Canvas). И, наконец, имейте в виду, что "WindowCanvas.Handle:= 0" не освобождает десктиптор, для его освобождения вы должны вызывать FreeHandle. [001576]


Письмо читателя

Как вывести на Canvas надпись под углом?

Nomadic советует:

Вот, взгляни.

...
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
{-create a rotated font based on the font object F}
var
LF : TLogFont;
begin
FillChar(LF, SizeOf(LF), #0);
with LF do begin
lfHeight           := F.Height;
lfWidth            := 0;
lfEscapement       := Angle*10;
lfOrientation      := 0;
if fsBold in F.Style then
lfWeight         := FW_BOLD
else
lfWeight         := FW_NORMAL;
lfItalic           := Byte(fsItalic in F.Style);
lfUnderline        := Byte(fsUnderline in F.Style);
lfStrikeOut        := Byte(fsStrikeOut in F.Style);
lfCharSet          := DEFAULT_CHARSET;
StrPCopy(lfFaceName, F.Name);
lfQuality         := DEFAULT_QUALITY;
{everything else as default}
lfOutPrecision     := OUT_DEFAULT_PRECIS;
lfClipPrecision    := CLIP_DEFAULT_PRECIS;
case F.Pitch of
fpVariable : lfPitchAndFamily := VARIABLE_PITCH;
fpFixed    : lfPitchAndFamily := FIXED_PITCH;
else
lfPitchAndFamily := DEFAULT_PITCH;
end;
end;
Result := CreateFontIndirect(LF);
end;

...

{create the rotated font}
if FontAngle <&tg; 0 then
Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты. [001614]


Письмо читателя

Как скопировать экран (или его часть) в TBitmap?

Nomadic советует:

Например, с помощью WinAPI так -

var
bmp: TBitmap;
DC: HDC;

begin

bmp:=TBitmap.Create;

bmp.Height:=Screen.Height;
bmp.Width:=Screen.Width;

DC:=GetDC(0);  //Дескpиптоp экpана

bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);

bmp.SaveToFile('Screen.bmp');

ReleaseDC(0, DC);
end;

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры

Var
Desktop :TCanvas ;
BitMap  :TBitMap;

begin
DesktopCanvas:=TCanvas.Create;
DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);
BitMap := TBitMap.Create;
BitMap.Width := Screen.Width;
BitMap.Height:=Screen.Height;
Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
DesktopCanvas, DesktopCanvas.ClipRect);
........
end;

[001618]


Delphi 1

Вертикальный текст

var
Hfont: Thandle;
logfont:TLogFont;
font: Thandle;
count: integer;
begin
LogFont.lfheight:=30;
logfont.lfwidth:=10;
logfont.lfweight:=900;
LogFont.lfEscapement:=-200;
logfont.lfcharset:=1;
logfont.lfoutprecision:=out_tt_precis;
logfont.lfquality:=draft_quality;
logfont.lfpitchandfamily:=FF_Modern;

font:=createfontindirect(logfont);

Selectobject(Form1.canvas.handle,font);

SetTextColor(Form1.canvas.handle,rgb(0,0,200));
SetBKmode(Form1.canvas.handle,transparent);

{textout(form1.canvas.handle,10,10,'Повернутый',7);}

for count:=1 to 100 do
begin
canvas.textout(Random(form1.width),Random(form1.height),'Повернутый');

SetTextColor(form1.canvas.handle,rgb(Random(255),Random(255),Random(255)));
end;

deleteobject(font);

end;

[001619]


Delphi 1

Вывод текста на родительском элементе управления

Свойство Canvas в TCustomControl существует, но оно защищено. Поскольку свойство canvas инкапсулирует windows HDC (Canvas.Handle), вы можете создавать объект TCanvas и назначать через свойство Handle контекст устройства элементу управления, на котором вы хотите рисовать.

Для примера:

procedure AControl.DrawLabel(ACaption: TCaption);
var
ACanvas: TCanvas;
DC: HDC;
begin
ACanvas:= TCanvas.Create;
try
WindowHandle:= parent.Handle;
DC := GetDeviceContext(WindowHandle);
ACanvas.Handle:= DC;
with ACanvas do
begin
end;
ACanvas.Handle:= 0;
ReleaseDC(WindowHandle, DC);
finally
ACanvas.free;
end;
end;

[001621]


Как рисовать прямо на экране?

Nomadic приводит следующий код:

........................................................
Procedure DrawOnScreen;
Var DC:HDC;
DesktopCanvas:TCanvas;
begin
DC:=GetDC(0);   // получили DC экрана
try
DesktopCanvas:=TCanvas.Create;
DesktopCanvas.Handle:=DC;
..................
// здесь рисуем на Canvas экрана
..................
finally
ReleaseDC(0,DC);
DesktopCanvas.Free;
end;
end;
........................................................

[001646]


Как быстро выводить графику? (А то Canvas очень медленно работает)

Nomadic советует:

Вот пример заполнения формами точками случайного цвета:

........................................................
type
TRGB=record
b,g,r:byte;
end;
ARGB=array [0..1] of TRGB;
PARGB=^ARGB;

var
b:TBitMap;

procedure TForm1.FormCreate(sender:TObject);
begin
b:=TBitMap.Create;
b.pixelformat:=pf24bit;
b.width:=Clientwidth;
b.height:=Clientheight;
end;

procedure TForm1.Tim1OnTimer(sender:TObject);
Var
p:PARGB;
x,y:integer;
begin
for y:=0 to b.height-1 do
begin
p:=b.scanline[y];
for x:=0 to b.width-1 do
begin
p[x].r:=random(256);
p[x].g:=random(256);
p[x].b:=random(256);
end;
end;
canvas.draw(0,0,b);
end;

procedure TForm1.FormDestroy(sender:TObject);
begin
b.free;
end;
........................................................

[001651]


Как бороться с "квадратичностью" Image

Аркадия советует:

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

Решение:

Вставляем картинку ,например с белым фоном, transpert:=true и на OnMouseOver, или еще где, пишем:

if image1.picture.bitmep.canvas.pixels[X, Y]<>clwhite then image1.cursor:=crHourGlass

else image1.cursor:=crDefault

Пояснение: при наведении прога проверяет цвет пиксела под указатем и если оно отличается от белого, т.е. цвета фона, то указатель меняет свой вид! [001702]


Delphi 2

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

var Image3: TImage;

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

procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Image3.Free;
end;

В настоящее время я также разбираюсь в других ответах на мой вопрос.

Попробуйте следующий HAX 244, взятый из Авг/Сен номера журнала Visual Developer. Это работает, и работает хорошо.

{ смотри текстовое описание за последним END. }
unit Scrncap;

interface
uses WinTypes, WinProcs, Forms, Classes, Graphics;

function CaptureScreenRect( ARect: TRect ): TBitmap;
function CaptureScreen: TBitmap;
function CaptureClientImage( Control: TControl ): TBitmap;
function CaptureControlImage( Control: TControl ): TBitmap;

implementation

{ используем следующий код для захвата прямоугольной области экрана }
function CaptureScreenRect( ARect: TRect ): TBitmap;
var ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;

ScreenDC := GetDC( 0 );
try
BitBlt( Canvas.Handle, 0, 0, Width, Height,
ScreenDC, Left, Top, SRCCOPY);
finally
ReleaseDC( 0, ScreenDC );
end;
end;
end;

{ используем следующий код для захвата целого экрана }
function CaptureScreen: TBitmap;
begin
with Screen do
Result := CaptureScreenRect( Rect( 0, 0, Width, Height ));
end;

{ используем следующий код для захвата клиентской области формы или элемента управления...}
function CaptureClientImage( Control: TControl ): TBitmap;
begin
with Control, Control.ClientOrigin do
Result := CaptureScreenRect( Bounds( X, Y, ClientWidth,

ClientHeight )); end;

{ используйте следующий код для захвата целой формы или элемента управления  }
function CaptureControlImage( Control: TControl ): TBitmap;
begin
with Control do
if Parent = nil then
Result := CaptureScreenRect( Bounds( Left, Top, Width,
Height ))
else
with Parent.ClientToScreen( Point( Left, Top )) do
Result := CaptureScreenRect( Bounds( X, Y, Width, Height ));
end;

end.

{
Источник:  Visual Developer, HAX #244, Авг/Сент 1996

захват экрана с помощью Delphi

В Delphi, если вы хотите получить изображение клиентской области формы, необходимо вызвать GetFormlmage. Но иногда возникает необходимость получения снимка формы целиком, вместе с заголовком, контуром и всем содержимым. Или целиком всего экрана. Если бы у вас был дефицит времени, мы бы в этом случае посоветовали показывать диалоговое окно с надписью "Теперь нажмите кнопку Print Screen!", после чего работать с изображением, помещенным в буфер обмена.

Но мы никуда не спешим. Комбинирование хостов Delphi с несколькими функциями GDI сводят задачу получения снимка экрана всего к одной строчке кода.

CaptureScreenRect, в листинге 1, демонстрирует это. Код получает экранный контекст устройства с помощью GetDC(O), и затем копирует прямоугольную область этого DC на холст изображения (Bitmap). Для копирования используется BitBlt. Смысл использования BitBlt (и любой функции GDI) в том, что Delphi помнит, что дескриптор холста есть DC, необходимый Windows.

Остальные функции копирования экрана в листинге 1 захватывают прямоугольник и отдает реальную работу на откуп CaptureScreenRect. CaptureScreen захватывает для прямоугольника целый экран. CaptureClientImage и CaptureControlImage захватывают прямоугольник области клиента и элемента управления, соответственно.

Эти четыре функции могут быть использованы для захвата любой произвольной области экрана, а также экранных областей форм, кнопок, полей редактирования, ComboBox'ов и пр.. Не забывайте после работы освобождать используемые вами картинки (Bitmap). }

[001733]


Письмо читателя

Как можно узнать количество цветов текущего режима?

Своим опытом делится Олег Кулабухов:

GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES)
Для получения общего количества битов, используемых для получения цвета используются следующие значения.
1 = 2 colors bpp
4 = 16 colors bpp
8 = 256 colors bpp
15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp
16 = 65535 colors bpp
24 = 16,777,216 colors bpp
32 = 16,777,216 colors (то же, что и 24) bpp
Вы можете использовать:
NumberOfColors := (1 shl
(GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES));
для подсчета общего количества используемых цветов. [001775]


Delphi 1

Назначение палитры Bitmap

Если вы рисуете на TImage....

Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в Timage нет. Затем палитру необходимо назначить. Вот пример:

//Устанавливаем Width и Height перед использованием Image1.Picture c Bitmap Canvasvar
Bitmap: TBitmap;
begin

Bitmap:=TBitmap.Create;
Bitmap.LoadfromFile({'Whatever.bmp'});

With Image2.Picture.bitmap do
Begin
Width:=Bitmap.Width;
height:=Bitmap.Height;
Palette:=Bitmap.Palette;
Canvas.draw(0,0,bitmap);
Refresh;
end;
end;

Если вы рисуете на канве формы...

Canvas.Draw(0,0,Bitmap);
SelectPalette(Form1.Canvas.handle,Bitmap.Palette,True);
RealizePalette(Form1.Canvas.Handle);

[001799]


Delphi 1

Прозрачный Bitmap

Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать.

Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.

Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.

Canvas.CopyMode := cmSrcAnd;
Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect);
{заполняем "пробелы" изображением}
Canvas.CopyMode := cmSrcPaint;
Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect);

[001800]


Delphi 1

Вращение изображения II

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

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

Для преобразования X- и Y-координат объявлены следующие переменные:

X,Y    = старые координаты пикселя
X1,Y1  = новые координаты пикселя
T      = угол вращения (в радианах)

R, A   - промежуточные величины, представляющие собой полярные координаты

R = Sqrt(Sqr(X) + Sqr(Y));

A = Arctan(Y/X);

X1 = R * Cos(A+T);

Y1 = R * Sin(A+T);
Я отдаю себе отчет, что это не оптимальное решение, поэтому, если вы найдете еще какое-либо решение, дайте мне знать. В действительности мой метод работает, но делает это очень медленно.

Создайте наложение пиксель-на-пиксель исходного изображение на целевое (используя свойство Canvas.Pixels).

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

Для начала вот мой вариант формулы вращения:

x, y = координаты в целевом изображении
t = угол
u, v = координаты в исходном изображении

x = u * cos(t) - v * sin(t)
y = v * cos(t) + u * sin(t)
Теперь, если я захочу решить эти уравнения и вычислить u и v (привести их к правой части уравнения), то формулы будут выглядеть следующим образом (без гарантии, по этой причине я и включил исходные уравнения!):
      x * cos(t) + y
u = --------------------
    sqr(cos(t)) + sin(t)

v =   y * cos(t) - x
    --------------------
    sqr(cos(t)) + sin(t)
Так, подразумевая, что вы уже знаете угол вращения, можно вычислить константы cos(t) и 1/sqr(cos(t))+sin(t) непосредственно перед самим циклом; это может выглядеть примерно так (приблизительный код):

ct := cos(t);
ccst := 1/sqr(cos(t))+sin(t);
for x := 0 to width do
for y := 0 to height do
dest.pixels[x,y] := source.pixels[Round((x * ct + y) * ccst),
Round((y * ct - x) * ccst)];

Если вы хотите ускорить этот процесс, и при этом волнуетесь за накопление ошибки округления, то вам следует обратить внимание на используемую нами технологию: мы перемещаем за один раз один пиксель, дистанция между пикселями равна u, v содержит константу, определяющую колонку с перемещаемым пикселем. Я использую расчитанные выше переменные как рычаг с коротким плечом (с вычисленной длиной и точкой приложения). Просто поместите в (x,y) = (1,0) и (x,y) = (0,1) и уравнение, приведенное выше:

duCol := ct * ccst;
dvCol := -ccst;

duRow := ccst;
dvRow := ct * ccst;

uStart := 0;
vStart := 0;

for x := 0 to width do
begin
u := uStart;
v := vStart;
for y := 0 to height do
begin
dest.pixels[x,y] := source.pixels[Round(u), Round(v)];
u := u + rowdu;
v := v + rowdv;
end;
uStart := uStart + duCol;
vStart := vStart + dvCol;
end;

Приведенный выше код можно использовать "как есть", и я не даю никаких гарантий отностительно его использования!

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

Xp, Yp (X-sub-p, Y-sub-p) точка оси вращения, другие константы определены выше
x = Xp + (u - Xp) * cos(t) - (y - Yp) * sin(t)
y = Yp + (y - Yp) * cos(t) - (x - Xp) * sin(t)
Оригинальные уравнения:
  x = u * cos(t) - v * sin(t)
  y = v * cos(t) + u * sin(t)
верны, но когда я решаю их для u и v, я получаю это:
      x * cos(t) + y * sin(t)
  u = -----------------------
     sqr(cos(t)) + sqr(sin(t))

      y * cos(t) - x * sin(t)
  v = ------------------------
      sqr(cos(t)) + sqr(sin(t))
[001803]


Delphi 1

Delphi и графика

Если вам нужно просто вывести одно изображение, создайте объект TBitmap, "поиграйтесь" с ним, а когда изображение будет готово появиться на экране, вызовите функцию Image.Canvas.Draw(0, 0, Bitmap), которая скопирует и нарисует его на экране. Как вы наверное заметили, основное время занимает рисование картинки на экране, а не установка ее атрибутов. В результате мы устанавливаем цвета на невидимом объекте (TBitmap мы уже создали), и отображаем только полностью готовый Bitmap. Вот демонстрационный код для формы с единственным на ней компонентом Image:

procedure TForm1.FormPaint(Sender: TObject);
Var
TmpX, TmpY : Byte;
MyImage : TBitmap;
begin
Form1.Width := 260;    Form1.Height := 260;
Image1.Width := 250;   Image1.Height := 250;
Image1.top := 5;       Image1.width := 5;
MyImage := TBitmap.Create;
MyImage.Width := 250;  MyImage.Height := 250;
FOR TmpX := 0 TO 249 DO
FOR TmpY := 0 TO 249 DO
MyImage.Canvas.Pixels[TmpX,TmpY] :=
RGB(TmpX, 250 - TmpY, (TmpX + TmpY DIV 2));
Image1.Canvas.Draw(0, 0, MyImage);
MyImage.Free;
end;

Если вы хотите сделать действительно быструю графику, взгляните на функции GDI (API) и/или функции WinG, которые для вас разработали программисты Microsoft. Трактовка их для данной статьи немного скучна, да и не имеет никакого отношения к Delphi. [001808]


Delphi 1

Рисование графов

...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.

Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)

var
x,l: Integer;
y,a: Double;
begin
Image1.Picture.Bitmap := TBitmap.Create;
Image1.Picture.Bitmap.Width := Image1.Width;
Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть
размещены в обработчике Form1.Create}
l := Image1.Picture.Bitmap.Width;
for x := 0 to l do
begin
a := (x/l) * 2 * Pi;  {Преобразуем позицию по оси X к углу между 0 & 2Pi}
y := Sin(a); {Ваша функция должна находиться здесь}
y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y}
y := y * -1; {Инвертируем Y, верх экрана это 0 !}
y := y + (Image1.Picture.Bitmap.Height / 2); {Добавляем компенсацию для среднего 0}
Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
end;
end;

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

[001809]


Письмо читателя

Как поместить прозрачный текст на Canvas Tbitmap?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject);

var

OldBkMode : integer;

begin

Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;

OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,

TRANSPARENT);

Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');

SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,

OldBkMode);

end;

[001810]


Delphi 1

Как быстро очистить канву?

InValidateRect(Canvas.handle,NIL,True);

Если вы используете холст формы, то попробуйте следующее:

InValidateRect(form1.handle,NIL,True);

(или взамен передать дескриптор компонента)

Это очистит хост:

canvas.fillrect(canvas.cliprect) ;

[001811]


Delphi 1

Получение DC элемента управления

{Bitmap в TImage}
HDC:=Image1.PICTURE.bitmap.canvas.handle;

DC - что-нибудь с Canvas.handle. [001815]


Письмо читателя

Как поменять цвет фона текста?

Своим опытом делится Олег Кулабухов:

procedure TForm1.Button1Click(Sender: TObject);
var
OldTextColor : TColorRef;
OldBkColor : TColorRef;
OldBkMode : Integer;
begin
OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255));
OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0));
OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
TextOut(Form1.Canvas.Handle,
100, 100,
'Blue text on red Background',
27);
SetBkMode(Form1.Canvas.Handle, OldBkMode);
SetBkColor(Form1.Canvas.Handle, OldBkColor);
SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;

[001818]


Совет читателя

Как во время компиляции модуля определить, под какой версией Delphi она происходит?

Из советов Nomadic'a:

Используйте

{$IFDEF VERXXX}
. . .
{$ELSE}
. . .
{$ENDIF}

Пользуйтесь вот такой таблицей:

     * VER80 -- Delphi 1
     * VER90 -- Delphi 2
     * VER93 -- C++Builder 1
     * VER100 -- Delphi 3
     * VER110 -- C++Builder 3
     * VER120 -- Delphi 4
     * VER130 -- Delphi 5
[001726]


Delphi 1

Связывание функций

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

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

...я тоже так хотел. Но одна из моих форм имела "uses dll_link", где dll_link являлся компонентом, который использовал dll. Хотя компонент и был удален из формы, программа сбоила, если на машине отсутствовала нужная DLL. Естественно, компоновщик удалил весь неиспользуемый код, но почему проблема осталась? Удаление "uses dll_link" решило проблему, и уменьшило размер exe на 100k. Очевидно, компоновщик не может это удалить сам.

Я так полагаю, что "умный" компоновщик ("Smart Linking") недостаточно умен для удаления ссылок на модули, в которых нет функций со внешними ссылками. Может, он делает это намеренно, но пока не ясно почему.

...я тоже задавался этим вопросом: почему, удаляя ссылки на ненужные мне модули, которые Delphi устанавливает по-умолчанию, размер выходного файла уменьшается - почему??? Что делает в это время умный оптимизатор - компилятор?

Я провел тест опции Delphi "Smart Linking" (умное связывание). Я создал пустое приложение, одно окно, ничего более. В обработчик события FormCreate я поместил две переменные и проинициализировал их: первая представляла собой строку, куда я поместил 'Привет!', вторая была Hwnd, куторой я присвоил дескриптор ("handle").

Я создал второй модуль. В этот модуль я включил ссылки на SysUtils, WinTypes и WinProcs. Я создал функцию с именем "This". "This" получает на входе два параметра: Hwnd и String. Она преобразует строку к типу C-строки, и вызывает MessageBox. Я захотел сделать так, чтобы функция "This" все-таки не была тривиальной (ну хорошо, она тривиальная).

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

Я собрал приложение, и запомнил размер exe-файла.

Затем я создал обработчик события FormCreate. В нем я вызывал "This" с переменными, инициализированными ранее (строка и дескриптор окна).

Я собрал приложение, и запомнил размер exe-файла.

Во втором случае (с вызовом функции "This") exe-файл получился больше на 300 байт. Из этого следует, что неиспользуемые функции не линкуются к exe-файлу.

Опция "Optimize for size and load time" (оптимизировать для размера и времени загрузки) весьма отличается от опции "smart-linking" (умное связывание). Очевидно, большинство компоновщиков сами по себе являются "умными машинками". Их технологию работы сложно понять, и это является самым строгим секретом фирмы. Некоторые теоретические выкладки можно почерпнуть из статьи, напечатанной в журнале MicroSoft Systems Journal, Июль 1993, статья называется "Liposuction your Corpulent Executables and Remove Excess Fat". Ее можно также найти на CD MSDN, если он у вас, конечно, имеется. По-крайней мере, в статье есть интересный раздел, посвященный технологии выравнивания ("alignment"), которую можно сравнить с проблемой выбора размера кластера в момент создания раздела на диске. Эта технология позволяет сэкономить, или потерять свободное место на диске при большом количестве файлов. В вопросе оптимизации существует масса мелочей. Во всяком случае, "Optimize for size and load time" выполняет ту же работу, что и прорамма W8LOSS.EXE (расположенной в каталоге \Delphi\Bin) с вашим скомпилированным приложением.

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

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

Типы не линкуются. Они используются только самим компилятором. Переменные "умным" компилятором не удаляются. Код, расположенный в секции initialization вызывается всегда. Процесс компиляции программ Delphi состоит из двух шагов: во-первых, компилируются все модули программы, после чего получаются двоичные промежуточные .DCU-файлы. Во-вторых, они полностью связываются все вместе и получается .EXE-файл. Во время второго шага удаляются любые функции/процедуры без внешних ссылок. Поэтому нет повода для беспокойства: ВСЕ функции, которые присутствуют в программе, будует помещены в .DCU-файл, и только те из них, которые реально используются, будут упакованы в EXE. Все будет работать именно так, как вы и ожидаете, нет никаких сюрпризов, в противном случае это связывание не будет 'smart' (умным), и эту опцию можно не включать.
[001793]


Delphi 1

Hard mode без перерыва II

ОПРЕДЕЛЕНИЕ: "Hard mode" является режимом Windows, при которой не происходит никакой обработки сообщений. Это происходит при отрисовке меню или некоторых операциях ядра. Это означает, что в этом состоянии Delphi не может "заморозить" ваше приложение, не блокируя Windows. Обычно это возникает вследствие многочисленных вызовов SendMessage. В этом случае, для выхода из Hard mode, необходимо "встряхнуть" систему. Вполне достаточно, если ваш отладчик покажет вам системно-модальное окно (messagebox), говорящее вам о том, что вы находитесь в hard mode! Для этого попробуйте поставить дополнительный breakpoint (точку останова) на строчке, *предшествующей* вашему breakpoint. В этом случае вы получите предупреждение о том, что система находится в hard mode, и этот же диалог "вышибет" систему из этого состояния. При нажатии на OK, вторая точка останова сработает как положено.

ПРИМЕЧАНИЕ: Поскольку работа отладчика построена на обработке сообщений, то он не может остановить работу в точке останова, если он "думает", что система вошла в режим hard mode, поскольку в этом случае вы не сможете ничего сделать, и система просто напросто зависнет. [001441]


При возникновении ошибки во время отладки программы машина перезагружается. Что делать?

Nomadic отвечает:

A: Снести QEMM. Начисто. Простое отключение его функций не помогает.
Впрочем, это исправлено в QEMM 9.0. [001491]


Delphi 2

Переустановка Delphi 2.0

Данный совет поможет вам в вопросе переустановки Delphi 2.0. Если вам понадобиться дополнительная помощь, пожалуйста, свяжитесь со службой "Горячей линии" по телефону (408) 461-9195.

Рекомендации по переустановке Delphi 2

  • Перед переустановкой Delphi 2.0, запустите утилиту удаления, щелкнув на иконке "add/remove program" (добавить/удалить программу) в Панели Управления Windows 95, или щелкнув на иконке "uninstall" в программной группе Delphi 2.0 в Windows NT.
    • Не запускайте процедуру удаления с Delphi 2.0 CD.

  • Перед удалением и переустановкой Delphi 2.0 завершите работу приложений, использующих Borland Database Engine и закройте Local InterBase Server (если он запущен), щелкнув на иконке Local InterBase (правой кнопкой мыши в системной панели задач Windows 95) и выбрав "shutdown".

  • Установка Delphi 2.0 в Windows NT требует Windows NT версии 3.51 или более поздней.

  • Перед установкой Delphi 2.0 убедитесь в том, что в Windows установлен самый последний service pack. Пакеты Service pack распространяются фирмой Microsoft Corporation. Хорошим источником является Интернет-сервер корпорации, расположенный по адресу www.microsoft.com.

  • Если в вашей системе уже установлена Delphi 1.0, Delphi 2.0 вы должны установить в другой каталог. Единственный каталог, рекомендуемый для общего пользования обоими версиями Delphi, каталог IDAPI.

  • Перед установкой убедитесь в том, что вы имеете права администратора системы.

  • Установка Delphi 2.0 на сетевой сервер не поддерживается.

  • Для установки Delphi 2.0 на компьютере, не имеющего привода CD-ROM, используйте сетевое соединение, или соединение через последовательный порт с использованием кабеля для параллельного или последовательного порта, копируйте установочные файлы с Delphi 2.0 CD во временный каталог компьютера, на котором вы хотите провести установку, и затем запустите программу установки из временного каталога компьютера, не имеющего CD-ROM. После успешной установки вы можете удалить файлы, которые вы скопировали во временный каталог.

  • Если на компьютере запущен stacker, переименуйте VSTACKER.386 (расположенный в вашем каталоге windows\system) в VSTACKER.$$$. Перезапустите Windows и снова запустите программу установки.

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

  • Ваша операционная система должна поддерживать длинные имена файлов.

  • Если на машине установлен Paradox, то перед установкой Delphi снимите со всех файлов блокировки.
Ошибки установки
  • Если мастер онлайн-регистрации не завершил до конца процедуру онлайновой регистрации, запустите снова процедуру установки и нажмите кнопку Cancel (отмена) на запрос онлайновой регистрации. Пожалуйста заполните и вышлите регистрационную карточку, включаемую в поставку вашего продукта Delphi 2.0.

  • Если в процессе установки вы получите пустое диалоговое окно, отмените установку и пробуйте снова, пока установка не пройдет успешно.

  • Если в процессе установки вы получите одно из следующих сообщений об ошибке:

    "out of disk space" (недостаточно места на диске),
    "no temp var" (нет временных переменных),
    "error 101" (ошибка 101)
    "error 102"(ошибка 102)

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

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

    "Install Shield error filename -51" (ошибка Install Shield при работе с файлом -51),

    то попробуйте сделать следующее:

    1. Скопируйте все файлы (КРОМЕ CTL3D32.DLL) из каталога runimage\delphi20\windows\system32, расположенного на Delphi 2.0 CD, во временную директорию вашего жесткого диска.

    2. Сбросьте флажок "read only" (только для чтения) во всех файлах, скопированных во временный каталог.

    3. Скопируйте файлы в ваш каталог windows\system, или windows\system32 для системы Windows NT.

    4. Снова запустите установку.
Другая информация, необходимая для успешной установки

  • Попробуйте выполнить установку с вашего жесткого диска. Чтобы сделать это, удалите Delphi 2.0, затем просто скопируйте файлы из каталога установки Delphi 2.0 CD во временный каталог вашего диска, после чего запустите из этого каталога программу установки. После успешной установки скопированные во временный каталог файлы можно удалить.

  • Временно переименуйте файл win.ini (расположенный в вашем каталоге Windows) в win.in$, перезагрузите систему и переустановите или перезапустите Delphi 2.0. Если это поможет, то причиной невозможности в установке Delphi могут быть любые программы, указанные в секции run или load файла win.ini, или нестандартные драйверы принтера.

  • Загрузите стандартный видеодрайвер, поставляемый с вашей системой Windows.

  • Проверьте атрибут "read-only" (только для чтения) для файлов, расположенных в каталогах Windows и windows\system.

Вопросы, которые могут возникнуть после установки

  • Если при попытке установки 32-битного ODBC драйвера для BDE вы получаете сообщение об ошибке "odbc is corrupt or not installed correctly" (ODBC испорчен или неправильно установлен) или "BDECFG32.EXE Error" (ошибка BDECFG32.EXE), то в первую очередь вам нужно установить 32-битный менеджер ODBC, доступный в InterSolv и Microsoft. Хорошим источником является Интернет-сервер корпорации Microsoft, расположенный по адресу www.microsoft.com.

  • Если вы установили Delphi 1.0 после установки Delphi 2.0, и Delphi 2.0 загружает файлы помощи от Delphi 1.0, удалите любые ссылки на файлы помощи Delphi 1.0 из файла WINHELP.INI, расположенного в вашем каталоге Windows.
[001079]


Как проводить локализацию своих приложений?

Nomadic советует:

В Delphi 3 и 4 есть специальные механизмы, позволяющие приложение "переделать" на любой язык после компиляции. Для D3 надо посмотреть в хелпе, по-моему, internationalization или что-то в этом роде. Для D4 вообще все делается ОЧЕHЬ просто:

  1. берется проект, компилируется;
  2. тут-же, не закрывая проект, вызвается New|Resource DLL Wizard, в нем указывается, какие формы и модули должны подвергнуться переводу на другой язык;
  3. в результате работы Wizard появляется проект (sic!) с RC и DFM. Открываем формы, и переделываем все сообщения + размер (соотв. длине сообщений);
  4. Компилируем. В результате получается файл xxxxxxx.rus, где xxxxxxx - название исходного проекта;
  5. Запускаем xxxxxxx.exe. Видим некий не наш язык. Подкладываем в каталог с этим exe изготовленный файл xxxxxxx.rus, и запускаем exe повторно. Видим абсолютно ВЕЗДЕ переведенные сообщения.
p.s. файл RUS можно подставлять и убирать по вкусу. [001100]


crtdll.dll в программах на Delphi

Здравствуйте.

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

Сначала немного о корнях проблемы. Не секрет, что в Delphi модуль Math поставляется только с Enterprise-версией программы. А платить больше тысячи долларов только за то, чтобы воспользоваться парой функций совсем не хочется (мне, например, простенькой atan2 часто не хватало).

Простым решением является "заимствование" модуля Math из пиратской Enterpise-версии, но это, вообще-то, воровство. Самому же создавать матеатическую библитеку с нуля - занятие неблагодарное (по крайней мере достаточно трудоёмкое).

Не работая плотно на MSVC я как-то был не в курсе наличия библиотеки crtdll.dll в Windows (насколько мне удалось выяснить, она таки является частью операционной системы, по крайней мере ставится вместе с Windows 9x/NT/2000). С её помощью можно решить указанную проблему, воспользовавшись готовым решением, а именно - объявить все необходые функции из math.h в своей программе и наслаждаться. :)

Пример с atan2:

function atan2(x, y: Double): Double; stdcall; external 'crtdll.dll' name 'atan2';

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

Да, в crtdll.dll много фукнций, не связанных с математикой, в частности, если вы в программе используете PChar, то можно воспользоваться набором сишных strcmp, strcpy..., так же доступны isalpha, isdigit..., и, наконец, bsearch и qsort. :)

С уважением,
Марк Шевченко. [001215]


Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме (но не в модальных окнах, к примеру)?

Nomadic советует:

Знакомая проблема. Лечится так:

function WindowHook(var Message: TMessage): Boolean;

procedure .FormCreate(Sender: TObject);
begin
// MainForm
Application.HookMainWindow(WindowHook);

function .WindowHook;
begin
Result := False;

with Message do
case Msg of
CM_APPKEYDOWN, CM_APPSYSCOMMAND: Msg := WM_NULL;

[001226]


При использовании MS SQL Server 6.5 в NT Performance Monitor исчезли все датчики, кроме SQL

Nomadic советует:

Кто виноват:

Дело в следующем - при инсталляции NT страна была поставлена US, затем сменена на Russia. В реестре для Perfomance Monitor существует (может существовать) сколь угодно подуровней с названием счетчиков и описанием к ним. При инсталляции все естестественно ставилось в ветвь 409 (US), а ветви 419 (Russia) просто не было. Потом default location была сделана Russia. Perfomance Monitor не мог найти 419 и брал все счетчики из 409. Hо тут пришел SQL и как умная программа при инсталляции создал ветвь 419 и запихал туда свои счетчики. Теперь Perfomance Monitor видит что текущая locale 419, в реестре она есть и берет оттуда счетчики, а они там только для SQL естественно.

Что делать:

Запускаешь regedit (regedt32), находишь где лежат описания счетчиков. Точно я не помню, под рукой NT нет, но примерно так - HKEY_LOCAL_MACHINE/System/CurrentControlSet/Control/PerfLib/409 (419). В каждом разделе по два ключа - список названий счетчиков и список их описаний. Заходишь в 409, открываешь ключ для изменений и при помощи Ctrl-Ins копируешь его содержимое в буфер обмена и жмешь Cancel. Теперь идешь в 419 открываешь тот же ключ, идешь в начало списка и при помощи Shift-Ins вставляешь, жмешь Ok. Так надо сделать и для названий счетчиков и для их описания. Для полного счастья можно и SQL счетчики из 419 в 409 (в конец) скопировать. [001305]


xWindows - FAQ

Артем Федюк прислал свой сборник любимых функций:

(*
Функции собрал Артем Федюк (Киев, 27.11.2000)
E-Mail: xartrain@hotmail.com
сообщите, пожалуйста о найденных ошибках
*)
{H+}//use huge strings
 unit XWindows;

INTERFACE
uses
classes,windows,shellApi,shlobj,sysUtils,
forms,mmsystem,controls,Messages,Registry,IniFiles;

{***************************ПРОЦЕССЫ И УПРАВЛЕНИЕ ИМИ**************************}
procedure execWait(const comLine:string);
procedure shellExec(const fileName:string);
//также можно использовать Sleep(ms:DWORD);
procedure Delay(msecs : DWORD);
//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning:boolean;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
stdcall; external 'KERNEL32.DLL';
procedure applicationInCtrlAltDelList(visi:boolean);
procedure applicationInTaskBar(visi:boolean);
//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
//Окно без закладки в TaskBar
procedure noAppInTaskbar;
//Определение какие приложения уже запущены
procedure ApplicationList(formHandle:THandle; var stringList:TStringList);

{***************************ВРЕМЯ**********************************************}
function SetTime(DateTime:TDateTime):Boolean;
//обновить часы - SendMessage(HWND_TOPMOST,WM_TIMECHANGE,0,0);

{***************************ИНТЕРФЕЙС WINDOWS**********************************}
//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
 function ShellFolder(const folderType:string):string;
procedure refreshWindowsDesktop;
procedure Startbutton(visi:boolean);
//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
//оч2истить меню "Документы"
procedure clearDocuments;
//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
 procedure addFileToDocuments(const fileName:string);
//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
{! проверить}procedure setWallPaper(const fileName:string; tile:boolean);

{***************************МОНИТОР********************************************}
 procedure RunCurrentScreenSaver;
//use application:TApplication object
procedure monitorState(state:boolean);

{***************************КЛАВИАТУРА*****************************************}
procedure RussianKbdLayout;
procedure EnglishKbdLayout;
procedure UkrainianKbdLayout;

{***************************МЫШЬ***********************************************}
//относительные координаты в абсолютные - function ClientToScreen(Pt:TPoint):TPoint;
procedure mouseEmul(absPoint:TPoint; up,down:boolean);
procedure mouseCursor(visi:boolean);
//просимулировать нажатие клавиши мыши
{! Не проверено}procedure SendMouseClick(x,y:integer;wHandle:THandle);

{**8*************************ДИСКОВЫЕ ФУНКЦИИ**********************************}
//8FAT,FAT32,CDFS,NWCOMPA
//0-"A",1-"B",2-"C"
 function GetFileSysName(Drive : Byte) : String;
function GetVolumeName(Drive : Byte) : String;
function DriveExists(Drive : Byte) : Boolean;
//'?';'Path2 does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
//Определение готовности дисковода к работе
function DiskInDrive(const Drive: char): Boolean;
function HDDSerialNum(const drivePath:string{'C:\'}):integer;

{***************************CD-ROM*********************************************}
 function getCdromPath:string;
procedure CDROMOpen;
procedure CDROMClose;

{***************************REGISTRY*******************************************}
 procedure StartFromRegistry(appName,appPath:string);
//запускается до WindowsLogon
procedure StartServiceFromRegistry(appName,appPath:string);
procedure StartFromWinIni(appPath:string);
function IsInstalled (FileExe: String): Boolean;

IMPLEMENTATION
(*
Вопрос:
Можно ли как-то уменьшить мерцание при перерисовке компонента?

Ответ:
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle
компонента - то фон компонента перерисовываться не будет.

Пример:

constructor TMyControl.Create;
begin
inherited;
//проверка "if not inIDE" должна быть вставлена в том случае,когда TMyControl - компонент
//чтобы среда IDE Delphi не глючила на этапе разработки
if not inIDE then ControlStyle := ControlStyle + [csOpaque];
end;
...
procedure Register;
begin
RegisterComponents('MyGraphics', [TMyControl]);
inIDE:=True;
end;

*)

procedure mouseCursor(visi:boolean);
Var
CState:Integer;
Begin
CState:= ShowCursor(True);
if visi then begin
//Включение курсора
while CState<0 do CState:=ShowCursor(True);
end
else begin
//Выключение курсора
while Cstate >= 0 do Cstate := ShowCursor(False);
end;
End;

//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
function ShellFolder(const folderType:string):string;
var registry:TRegistry;
begin
result:='';
Registry := TRegistry.Create;
try
Registry.RootKey := HKey_Current_User;
Registry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
result:= Registry.ReadString(folderType);
finally
Registry.Free;
end;
end;

procedure SetWallpaper(const fileName:string;tile:boolean);
var
Reg: TRegIniFile;
begin
Reg:=TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', fileName);
if tile then
Reg.WriteString('desktop', 'TileWallpaper', '1')
else
Reg.WriteString('desktop', 'TileWallpaper', '0');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil,SPIF_SENDWININICHANGE);
end;

{procedure setWallPaper(fileName:string);
begin
SystemParametersInfo(SPI_SETDESKWALLPAPER,0,pChar(fileNAme),0);
end;}

procedure refreshWindowsDesktop;
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_COMMAND,
$A065,
0);
end;

procedure mouseEmul(absPoint:TPoint; up,down:boolean);
begin
//Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"),
//где 65535 "Mickeys" равно ширине экрана.
absPoint.x := Round(absPoint.x * (65535 / Screen.Width));
absPoint.y := Round(absPoint.y * (65535 / Screen.Height));
{Переместим курсор мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_MOVE,
absPoint.x,
absPoint.y,
0,
0);
if down then
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTDOWN,
absPoint.x,
absPoint.y,
0,
0);
if up then
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTUP,
absPoint.x,
absPoint.y,
0,
0);
end;

//просимулировать нажатие клавиши мыши
procedure SendMouseClick(x,y:integer;wHandle:THandle);
begin
sendmessage(wHandle,WM_LBUTTONDOWN,MK_LBUTTON,x+(y shl 16));
sendmessage(wHandle,WM_LBUTTONUP,MK_LBUTTON,x+(y shl 16));
application.processMessages;
end;

procedure monitorState(state:boolean);
begin
if state then
SendMessage(Application.Handle,
wm_SysCommand,
SC_MonitorPower,
-1)
else
SendMessage(Application.Handle,
wm_SysCommand,
SC_MonitorPower,
0);
end;

procedure execWait(const comLine:string);
var
si:Tstartupinfo;
p:Tprocessinformation;
begin
fillChar( Si, SizeOf( Si ) , 0 );
with Si do  begin
cb := SizeOf( Si);
dwFlags := startf_UseShowWindow;
wShowWindow := 4;
end;
Createprocess(nil,pChar(comLine),nil,nil,false,Create_default_error_mode,nil,nil,si,p);
Waitforsingleobject(p.hProcess,infinite);
end;

procedure shellExec(const fileName:string);
begin
shellExecute(0,Nil,pChar(fileName),Nil,Nil,SW_NORMAL);
end;

procedure Delay(msecs : DWORD);
var
FirstTick : DWORD;
begin
FirstTick:=GetTickCount;
repeat
Application.ProcessMessages;
until GetTickCount-FirstTick >= msecs;
end;

function HDDSerialNum(const drivePath:string{'C:\'}):integer;
var
SerialNum:Pdword;
a,b:Dword;
buffer:array [0..255] of char;
begin
result:=0;
new(SerialNum);
if getVolumeInformation(pChar(drivePath),buffer,sizeof(buffer),SerialNum,a,b,nil,0) then
result:=SerialNum^;
Dispose(SerialNum);
end;

//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning: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;
begin
result:=false;
H1 := FindWindow(A1, nil);
H2 := FindWindow(A2, nil);
H3 := FindWindow(A3, nil);
H4 := FindWindow(A4, nil);
if (H1 <> 0) and (H2 <> 0) and (H3 <> 0) and (H4 <> 0) then result:=true;
end;

function getCdromPath:string;
var
w:dword;
Root:string;
i:integer;
begin
result:='';
w:=GetLogicalDrives;
Root := '#:\';
for i := 0 to 25 do begin
Root[1] := Char(Ord('A')+i);
if (W and (1 shl i))>0 then
if GetDriveType(Pchar(Root))=DRIVE_CDROM then begin
result:=Root;
exit;
end;
end;
end;

//Определение готовности дисковода к работе
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 soundCardExists:boolean;
begin
if WaveOutGetNumDevs>0 then result:=true
else result:=false;
end;

function SetTime(DateTime:TDateTime):Boolean;
var
st:TSystemTime;
ZoneTime: TTimeZoneInformation;
begin
GetTimeZoneInformation(ZoneTime);
DateTime:=DateTime+ZoneTime.Bias/1440;
with st do begin
DecodeDate(DateTime,wYear,wMonth,wDay);
DecodeTime(DateTime,wHour,wMinute,wSecond,wMilliseconds);
end;
result:=SetSystemTime(st);
SendMessage(HWND_TOPMOST,WM_TIMECHANGE,0,0);
end;

//Окно без закладки в TaskBar
procedure noAppInTaskbar;
begin
ShowWindow(Application.Handle,sw_Hide);
end;

//Определение какие приложения уже запущены
procedure ApplicationList(formHandle:THandle; var stringList:TStringList);
var
Wnd : hWnd;
buff: ARRAY [0..127] OF Char;
begin
stringList.Clear;
Wnd := GetWindow(formHandle, gw_HWndFirst);
WHILE Wnd <> 0 DO BEGIN {Не показываем:}
IF (Wnd <> Application.Handle) AND {-Собственное окно}
IsWindowVisible(Wnd) AND {-Невидимые окна}
(GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков}
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
stringList.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
end;

procedure CDROMOpen;
begin
mciSendString('Set cdaudio door open wait', nil, 0, 0);
end;

procedure CDROMClose;
begin
mciSendString('Set cdaudio door closed wait', nil, 0, 0);
end;

//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
var old:Boolean;
begin
old:=True;
if state then
//Восстановить
SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@old,0)
else
//Убрать
SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@old,0);
end;

procedure StartButton(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
If Visi then ShowWindow(Child, 1)
else ShowWindow(Child, 0);
end;
End;
Child := GetWindow(Child, GW_HWNDNEXT);
End;
End;

//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
begin
if visi then
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_SHOW) // Показать Taskbar
else
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_HIDE); //Скрыть TaskBar
end;

procedure applicationInCtrlAltDelList(visi:boolean);
begin
if visi then begin
//Show
RegisterServiceProcess(GetCurrentProcessID, 0);
end
else begin
//Hide
RegisterServiceProcess(GetCurrentProcessID, 1);
end;
end;

procedure applicationInTaskBar(visi:boolean);
begin
if visi
then windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_SHOW)
else windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE);
end;

procedure RussianKbdLayout;//На русский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;

procedure EnglishKbdLayout;//На английский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;

procedure UkrainianKbdLayout;//На украинский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,
pChar(intToHex(LANG_UKRAINIAN+$400,8))),
KLF_ACTIVATE);
end;

//запустить текущий ScreenSaver
 procedure RunCurrentScreenSaver;
begin
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_SCREENSAVE,0);
end;

//очистить меню "Документы"
procedure clearDocuments;
begin
SHAddToRecentDocs(SHARD_PATH,nil);
end;

//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
 procedure addFileToDocuments(const fileName:string);
begin
SHAddToRecentDocs(SHARD_PATH,pchar(fileName));
end;

//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
var
DC:HDC;
begin
DC:=GetDC(0);
Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96);
{ В случае крупного шрифта будет 120}
ReleaseDC(0, DC);
end;

function DriveExists(Drive : Byte) : Boolean;
begin
Result := Boolean(GetLogicalDrives AND(1 SHL Drive))
end;

//'?';'Path does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
var
DriveLetter : Char;
DriveType   : UInt;
begin
DriveLetter := Char(Drive + $41);
DriveType   := GetDriveType(PChar(DriveLetter + ':\'));
Case DriveType of
0               : Result := '?';
1                : Result := 'Path does not exists';
DRIVE_REMOVABLE : Result := 'Removable';
DRIVE_FIXED     : Result := 'Fixed';
DRIVE_REMOTE    : Result := 'Remote';
DRIVE_CDROM     : Result := 'CD-ROM';
DRIVE_RAMDISK   : Result := 'RAMDISK'
Else  Result := 'Unknown';
end;
end;

//GetVolumeInformation
function GetFileSysName(Drive : Byte) : String;
var
DriveLetter  : Char;
NoMatter     : DWORD;
FileSysName  : Array[0..MAX_PATH] of Char;
begin
DriveLetter  := Char(Drive + $41);
GetVolumeInformation(PChar(DriveLetter + ':\'),
Nil,
0,
nil,
NoMatter,
NoMatter,
FileSysName,
SizeOf(FileSysName));
Result := FileSysName;
end;

function GetVolumeName(Drive : Byte) : String;
var
DriveLetter  : Char;
NoMatter     : DWORD;
VolumeName   : Array[0..MAX_PATH] of Char;
begin
DriveLetter  := Char(Drive + $41);
GetVolumeInformation(PChar(DriveLetter + ':\'),
VolumeName,
SizeOf(VolumeName),
nil,
NoMatter,
NoMatter,
Nil,
0);
Result := VolumeName;
end;

procedure StartFromRegistry(appName,appPath:string);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',
true{canCreate});
reg.WriteString(appname,appPath);
reg.CloseKey;
reg.free;
end;

procedure StartServiceFromRegistry(appName,appPath:string);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\RunServices',
true{canCreate});
reg.WriteString(appname,appPath);
reg.CloseKey;
reg.free;
end;

procedure StartFromWinIni(appPath:string);
var
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows',
'run',
'');
if s = '' then
s := appPath
else
s := s + ';' + appPath;
WinIni.WriteString('windows',
'run',
s);
WinIni.Free;
end;

function IsInstalled (FileExe: String): Boolean;
var
reg : TRegistry;
temp: String;
begin
result:=False;
reg:= Tregistry.Create;
try
reg.RootKey:= HKEY_LOCAL_MACHINE;
if reg.OpenKey ('\Software\Microsoft\Windows\CurrentVersion\App Paths\'
+FileExe,
false)
then begin
if reg.ValueExists('') then begin
temp := reg.readString('Path');
result := FileExists(temp+'\'+FileExe);
end;
end;
finally
reg.Free;
end;
end;

END.

[001462]


Delphi 1

Код ASCII для EOF

Стандартный маркер DOS EOF - control-Z, или символ ASCII 26. [001676]


Бесполезное

`Cамоубийство` программы

Nomadic советует попробовать такой код:

if CreateProcess( nil, PChar(batName), nil, nil, False,
IDLE_PRIORITY_CLASS,   //or DETACHED_PROCESS для консольных пpиложений
nil, nil, si, pi ) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;

[001728]


Самоделкины

Создаём собственный UnRar, используя unrar.dll

Nomadic советует попробовать такой код:

// Объявления

function RAROpenArchive(ArchiveData : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RAROpenArchive';

function RARCloseArchive(hArcData : Integer): Integer; stdcall;
external 'unrar.dll' name 'RARCloseArchive';

function RARReadHeader(hArcData : Integer; HeaderData : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RARReadHeader';

function RARProcessFile(hArcData : Integer; Operation : Integer; DestPath : Pointer;
DestName : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RARProcessFile';

const
ERAR_END_ARCHIVE = 10;
ERAR_NO_MEMORY = 11;
ERAR_BAD_DATA = 12;
ERAR_BAD_ARCHIVE = 13;
ERAR_UNKNOWN_FORMAT = 14;
ERAR_EOPEN = 15;
ERAR_ECREATE = 16;
ERAR_ECLOSE = 17;
ERAR_EREAD = 18;
ERAR_EWRITE = 19;
ERAR_SMALL_BUF = 20;

RAR_OM_LIST = 0;
RAR_OM_EXTRACT = 1;
RAR_SKIP = 0;
RAR_TEST = 1;
RAR_EXTRACT = 2;
RAR_VOL_ASK = 0;
RAR_VOL_NOTIFY = 1;

type
Char260 = Array [1..260] of Char;

TRAROpenArchiveData = record
ArcName : PChar; // в C++ это будет выглядеть как: char *ArcName
OpenMode : Cardinal;
OpenResult : Cardinal;
CmtBuf : PChar;
CmtBufSize : Cardinal;
CmtSize : Cardinal;
CmtState : Cardinal;
end;

TRARHeaderData = record
ArcName : Char260;
FileName : Char260;
Flags : Cardinal;
PackSize : Cardinal;
UnpSize : Cardinal;
HostOS : Cardinal;
FileCRC : Cardinal;
FileTime : Cardinal;
UnpVer : Cardinal;
Method : Cardinal;
FileAttr : Cardinal;
CmtBuf : PChar;
CmtBufSize : Cardinal;
CmtSize : Cardinal;
CmtState : Cardinal;
end;

var
RARExtract : boolean;
RAROpenArchiveData : TRAROpenArchiveData;
RARComment : array [1..256] of Char;
RARHeaderData : TRARHeaderData;

...

procedure ExtractRARArchive;
var
sDir : string;
s : string;
sTest : string;
iTest : integer;
bTestDone : boolean;
RARhnd : Integer;
RARrc : Integer;
PDestPath : Char260;

begin
RARExtract:=TRUE;
lKBWritten:=0;
ProgressBar2.Position := 0;
ProgressBar2.Max := lTotalSize;
RARStartTime:=Time;

RAROpenArchiveData.OpenResult:=99;
RAROpenArchiveData.OpenMode := RAR_OM_EXTRACT; // открываем для распаковки
RAROpenArchiveData.ArcName:= @RARFileName;
RAROpenArchiveData.CmtBuf := @RARComment;
RAROpenArchiveData.CmtBufSize := 255;

// Открываем RAR архив и выделяем память
RARhnd := RAROpenArchive (@RAROpenArchiveData);
If RAROpenArchiveData.OpenResult <> 0 then
begin
case RAROpenArchiveData.OpenResult of
ERAR_NO_MEMORY : s:='Not enough memory to initialize data structures';
ERAR_BAD_DATA : s:='Archive header broken';
ERAR_BAD_ARCHIVE : s:='File is not valid RAR archive';
ERAR_EOPEN : s:='File open error';
end;
MessageDlg('Unable to open rar archive: ' + s + '!',mtError, [mbOK], 0);
end;

RARSetProcessDataProc(RARhnd,@Form.OnRarStatus);
StrPCopy(@PDestPath, EInstallPath.Text);

repeat
RARrc := RARReadHeader (RARhnd, @RARHeaderData);// Читаем заголовок
if RARrc <> ERAR_END_ARCHIVE then
begin
ProgressBar1.Position := 0;
ProgressBar1.Max := RARHeaderData.UnpSize;
s:=RARHeaderData.FileName;
lblCurrentFile.Caption := s;
lKBytesDone := 0;
end;

if RARrc = 0 then
RARrc:=RARProcessFile (RARhnd, RAR_EXTRACT, @PDestPath, nil);
if (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then
begin
MessageDlg('An Error occured during extracting of ' + sTest+'!' + #13#10 +
'RARProcessFile: ' + MakeItAString(RARrc),mtError, [mbOK], 0);
end;
until RARrc <> 0;

// закрываем RAR архив и освобождаем память
If RARCloseArchive(RARhnd) <> 0 then
begin
MessageDlg('Unable to close rar archive!',mtError, [mbOK], 0);
end;
end; // ExtractRARArchive

[001749]