На свой процесс я всегда создаю один экземпляр Excel.Application. Уже пару лет все отчеты у меня - это отчеты Excel. Я написал несколько классов, которые мне очень помогают в этом. Сегодня у меня целая “отчетная” подсистема, зашитая в класс и обслуживающая непомерно большие запросы моих пользователей. В промежутках между работой с отчетами нет необходимости “мозолить глаза” лишним окном в TaskBar-е. Вот и прячу я этот Excel. Это очень просто и комментариев, думаю, не требует:
Delphi 4.0 / 5.0
procedure TForm1.HideExcel;
begin
if Assigned(FIXLSApp) then begin
FIXLSApp.Visible[0] := false;
end;
end;
Декабрь
29,
2007
— Рубрика: Delphi
Метки: Excel, Excel.Application, TaskBar
Вот здесь начинаются хитрости. Любой, читавший помощь по Excel VBA, скажет, что достаточно написать FIXLSApp.Visible := true. Не тут-то было. Я делаю так:
Delphi 4.0 / 5.0
procedure TForm1.ShowExcel;
begin
if Assigned(FIXLSApp) then begin // а если он не создан?
FIXLSApp.Visible[0] := true;
if FIXLSApp.WindowState[0] = TOLEEnum(xlMinimized) then
FIXLSApp.WindowState[0] := TOLEEnum(xlNormal);
FIXLSApp.ScreenUpdating[0] := true;
end;
end;
Зачем здесь условие на минимайз и какой-то ScreenUpdating? Давайте попробуем закомментировать эти строки, остаиви только Visible, запустить проект, создать Excel (кнопка CreateExcel), показать его (кнопка ShowExcel), минимизировать, вернуться в приложение и сделать снова ShowExcel. Да-да, Visible = true переводит фокус в минимизированный Excel, не восстанавливая размеры окна. Это ситуация, с которой я борюсь условием на xlMinimized. Но ScreenUpdating зачем?
Знающие люди говорят, что это свойство отвечает за перерисовку окон Excel. Это все равно, что DisableControls у TDataSet. Добавляет скорости, если в нем false. И это правда что, если выключить его во время длительных пересчетов, то быстрее пересчитается. Но мы, ведь, не выключали его. Зачем тогда эта строка?
Делаем так: комметируем эту строку, запускаем демо, CreateExcel, ShowExcel, закрываем его (можно кнопкой с крестиком в правом верхнем углу окна, кому нравится - через меню “Файл/Выход”). Знающие люди скажут, что Excel на самом деле не закрыт. Интерфейс мы не освободили, поэтому в TaskManager мы его и увидим. Итак, Excel по-прежнему у нас в руках. Мы имеем право сделать ему снова Show.
После такого действия у меня возникает ощущение, что я переплатил за свою видеокарту. Фокус в Excel-е, но я по-прежнему наблюдаю форму демо-проекта. Видимо, программисты из MS не рассчитывали на то, что кто-то закроет Excel, вызванный через создание Excel.Application, а потом захочет увидеть его снова. Но я-то захотел?!
Свойства Visible, WindowState и ScreenUpdating вызываются с каким-то непонятным индексом массива - 0. В модуле Excel TLB во многих свойствах и методах вы можете встретить параметр или индекс lcid. Не помню, у кого я это прочитал (Калверт или Канту), но с тех пор я туда передаю всегда 0. И все работает. LCID - это что-то насчет
Декабрь
28,
2007
— Рубрика: Delphi
Метки: Excel, WindowState
Модуль импортированной Excel TLB (неважно, для D4 или D5) содержит описания всех интерфейсов, которые правильные программисты из Microsoft решили выставить наружу. Там есть все необходимое: типы, константы и интерфейсы. Этого вполне достаточно для работы с Excel-ом из Delphi-приложения (во написал! а что еще нужно-то?). Я создаю Excel для последующего его использования с помощью такого кода:
Delphi 4.0
procedure TForm1.CreateExcel(NewInstance: boolean);
var IU: IUnknown;
isCreate: boolean;
begin
// FIXLSApp - private-поле у формы
// у меня в привычке добавлять букву I для всех интерфейсов
// понятно почему FI… ?
if not Assigned(FIXLSApp) then begin // а зачем создавать, если уже есть?
isCreate := NewInstance or
(not SUCCEEDED( GetActiveObject(CLASS_Application_, nil, IU) ) );
if isCreate then
FIXLSApp := CreateComObject(CLASS_Application_) as _Application
else
FIXLSApp := IU as _Application;
end;
end;
Этот достаточно простой код вы найдете практически во всех книгах, посвященных работе с интерфейсами. Как и везде, я напишу, что в результате выполнения этого кода создастся объект COM с CLSID-ом “{00024500-0000-0000-C000-000000000046}” (читайте и перечитывайте Калверта, это не только укрепляет сон!).
Delphi 5.0
procedure TForm1.CreateExcel(NewInstance: boolean);
begin
if not Assigned(IXLSApp) then begin
FIXLSApp := TExcelApplication.Create(Self);
if NewInstance then FIXLSApp.ConnectKind := ckNewInstance;
FIXLSApp.Connect;
end;
end;
В отличие от предыдущих версий, Delphi 5.0 предоставляет более удобный сервис при импорте библиотек типов. Большой шаг вперед - появление класса ToleServer с поддержкой событий. Теперь работа с существующими и создание новых OLE-серверов стала намного удобней. Как видите, не приходится обращаться к низкоуровневым функциям. Впрочем, в Delphi 4.0 тоже существовал этот класс, только не от Borland. Отличная библиотека была создана Бином Ли (Binh Ly) в COM Nodes - это Threading COM Library. С легкой руки Алексея Вуколова (специальное спасибо!) я использовал ее для построения масштабируемых COM-серверов в сервисах WinNT.
Обращу ваше внимание только на параметр NewInstance. Он позволяет создать новый процесс. Я часто задаю себе вопрос - “А нужен ли NewInstance?”. Одна копия процесса, все ж, требует меньше памяти. Но еще чаще я думаю - “Боже, как хорошо я сделал, когда создал новый процесс!”. Почему? Если вы не хотите потерять уже открытые, но еще не сохраненные книги, экспериментируя даже с моими примерами, создавайте новый процесс. Печальный опыт научил меня использовать GetActiveObject только в случае полной уверенности в коде, который будет выполняться после. Поэтому, мой вам совет, тестируйте свои приложения только с NewInstance. Или закрывайте важные книги пред этим. Excel - хитрая программа, бывает, улетает в неизвестность, ни слова не сказав. Это не вина Microsoft. Это неудачное расположение звезд.
Декабрь
25,
2007
— Рубрика: Delphi
Метки: Delphi, Excel.Application
А просто. Создал “Excel.Application”, использовал его по назначению, “убил” и готово. Вот именно об этом я и попытаюсь написать здесь.
Важно! Параллельно с написанием статьи создавался демо-проект (точнее два - для Delphi 4 и 5), где вы сможете найти весь код примеров статьи. Проект для Delphi 4.0 использует импортированную Type Library из Excel 97. Здесь я использую ранее связывание, ибо CreateOLEObject отлично описал мой любимый классик в “Delphi 4 Unleashed” (мне ли с ним тягаться?). Кроме того, обращайтесь к комментариям в исходных текстах этого проекта. Местами там написано намного понятней, нежели здесь. Delphi 5 содержит более удобный механизм импорта библиотек типов с поддержкой событий и прекрасной генерацией ко-классов. Специально для счастливых обладателей Delphi 5 (я тоже им являюсь) я создал проект, но уже применительно к TexcelApplication (правда ли, что импортированный MS Office есть только в версии Enterprise?). Примеры кода я буду приводить сначала для Delphi 4, потом для Delphi 5. Заранее приношу прощения за дублирование информации в комментариях и в статье - писал сразу везде.
И еще. Эффективная работа с Excel-ом из Delphi-приложений немыслима без знания одной важной вещи. И имя ей - интерфейс. Мне, конечно, хотелось бы написать о принципах работы с интерфейсами здесь, в этой статье. Более того, я обещал сделать это самой Королеве. Но…
Мне ли (совсем еще не профессионалу - и это так!) пытаться сделать это лучше, чем классики этой области. Я честно признаюсь, что не смогу этого сделать быстро (в небольшом объеме) и качественно. Поэтому всякого, не знакомого еще с этой областью программирования, я с глубочайшими извинениями отсылаю к книге Чеппела “OLE Inside”.
Достойную помощь (уже применительно к Delphi) может вам оказать “Delphi 4 Unleashed” Чарльза Калверта.
Декабрь
21,
2007
— Рубрика: Delphi
Метки: Delphi, Excel, OLE Inside
Собственно, цель этой статьи мне понятна - поделиться своим опытом с народом. Делюсь…
Итак, зачем нам, лучшим в мире программистам, нужен Excel, порождение “злого” гения Microsoft? Конечно, часто это лишнее - “юзать” Excel для отчетов. Напечатать “платежку” можно и в QReport-е. Но…
Есть заказчики, готовые отдать “кучищи” денег за то, что они будут знать все и всегда о своем предприятии. Да еще, чтоб это было красиво и со вкусом.
Приезжает один из моих заказчиков (немец - они повсюду! курорты Испании просто куплены ими - это знаю наверняка) на свое местное предприятие и начинает задавать интересные вопросы. Как трудились за время его отсутствия, сколько продукции выпустили, кому сколько отгрузили, в разных валютах, итого в USD и пр.? А я ему в ответ открываю отчет, неслабый такой, - сводная таблица по движению готовой продукции (посвященные знают, что это 40-ой счет в бухгалтерии). А в ней одних PageField-ов десяток. И на каждый его вопрос я начинаю отвечать не напрягаясь, потихоньку перетаскивая поля таблицы туда-сюда, фильтрую кое-что, строю диаграммы. Что, вы думаете, было потом? Он, как маленький ребенок, сидел за этой сводной таблицей несколько часов, все восхищался. И правильно, наши программисты круче ихних! Заодно и мы спокойно поработали (ему занятие нашлось). О деньгах тут вообще не говорим.
Потом я ему показал, как эту самую сводную таблицу в Сеть можно опубликовать. Сейчас просит, чтоб ему доступ из Германии сделали к этой табличке. Мы, конечно, рады стараться.
Я бы привел еще несколько примеров, но, думаю, читатели уже поняли меня. Excel - вещь практически незаменимая во всяческих анализах (не путать с поликлиникой). А для тех, кто не понял, я еще напишу. Отдельно.
Декабрь
19,
2007
— Рубрика: Delphi
Метки: Excel, отображение
Недавно занимаясь интересной задачкой по написанию службы индексации, столкнулся с интересным вопросом: ” А как бы нам поиск заморозить и продолжить после (через минуту, завтра, через месяц)?”. Да конечно можно сказать - что у тебя за машина такая, вот у меня дерево каталогов обходит за 3 минуты… Согласен, это не вопрос. Но когда нужно не просто обходить, а еще и выполнять некоторые действия с файлами, да если их на диске 150 тыс. и больше, да еще не загружая процессор на 100%, то время может затянуться до нескольких суток, вот тогда - как быть?
Вот этой теме я и решил посвятить статью. Как оказалось, в Интернете информации по этой теме нет. Либо это слишком просто, либо никому не нужно. Как выяснилось - ни то ни другое.
Со стандартной процедурой обхода дерева сталкивались очень многие
procedure FileFind(path:string);
var sr:Tsearchrec;// Описываем структуру, которую использует для поиска система
found:integer; // найдено или нет
begin
found:=FindFirst(path + ‘\*.*’, FaAnyfile, sr); {по команде FindFirst программа создает
структуру следующего типа
TsearchRec = record
Time: Integer; // время создания
Size: Integer; // его размер
Attr: Integer;// атрибуты
Name:TFileName // = TString; собственно имя файла
ExcludeAttr: Integer; найденные атрибуты
FindHandle: THandle; // !!! указатель на структуру поиска, которую создает система,
а не наша программа. Вот для чего обязательно в конце поиска указывать FindClose -
это высвобождает память
FindData: TWin32FindData; // собственно эта структура
end;}
while (found = 0) do // если хоть чтото найдено
begin
if (sr.name <> ‘.’) and (sr.name <> ‘..’) then
begin // если это не указатели на корневые каталоги, то чтото нашли
if (sr.attr and FaDirectory) = FaDirectory then
// ага вот поддиректория - вызываем себя рекурсивно, но с поиском уже в этой директории
FileFind(path+’\'+sr.name)
else
begin
// вот тут выполняем чтото с найденным файлом
……
mainform.memo1.lines.append(path+’\'+sr.name);
end
end;
found:=findnext(sr); // есть ли еще файлы или каталоги
end;
FindClose(sr); // поиск закончен - нужно освободить память
end;
Казалось бы сохранить состояние процедуры поиска просто - достаточно сохранить структуру - sr:TsearchRec, а потом ее восстановить и поиск продолжится.
Первое - Однако при даже невнимательном рассмотрении процедуры видно, что она вызывает сама себя - налицо обычная рекурсия. Получается что надо сохранять не одну SearchRec, а несколько. Полдела - сохранить, но ведь нужно и восстановить эти рекурсивные вызовы. Т.е при продолжении поиска построить этакую матрешку из процедур поиска, а потом уже его продолжать.
Второе - сама SearchRec. Казалось бы она находится в области данных нашей программы. Да это наполовину верно. Верхняя половина SearchRec действительно лежит в области данных нашей программы и делать мы с ней можем что душе угодно. Это переменные Time: Integer; Size: Integer; Attr: Integer; Name:TFileName; ExcludeAttr: Integer;. А вот вторая ее половина (FindHandle: THandle; FindData: TWin32FindData;) нам не принадлежит - ее генерирует система по нашему запросу FindFirst(…..) и уничтожает по команде FindClose(….).
Третий казалось бы простой вопрос - SearchRec.Name имеет тип TFileName=TString. Какую длину он имеет? Одни скажут 255, другие 65535. Согласен, и то и другое верно, но не тут. Длина действительно 255. А вот с типом нас нагло обманули. Реально в памяти хранится не TString [255], а PChar {Имя файла}+PChar{его расширение}. Для нас с вами это преобразуется в обычную строку при обращении, и до столкновения с данной ситуацией я свято верил что там TString[255]. Кстати в чем разница между Богом и билом гейтсом? Бог не считает себя билом гейтсом …
И так попробуем решить эти проблемы. Проше всего разбор начать в обратном порядке… (не подумайте превратно, я знаю через что рвут гланды в России…)
Третий вопрос - как сохранить , а потом восстановить SearchRec, если он состоит непонятно из чего. А давайте сделаем свой SearchRec, как нам нужно. А именно так
type // этот тип почти полностью переписывается со стандартного TSearchRec
TMysearchRec = record
Time: Integer;
Size: Integer;
Attr: Integer;
Name: string[250];//вот тут обрабатывалось неверно при типе TString, как длина ?
ExcludeAttr: Integer;
FindHandle: THandle; // в принципе не нужен, но не будем сильно пугать читателей
// сильными отличиями, да и бог с ними - с восемью байтами
FindData: TWin32FindData;
end;
но нам еще требуется сохранять несколько переменных самой программы, а именно Found - найдено чтото или нет и Path - с каким параметром нас вызывали, поэтому на основе этого типа делаем еще один
TMyRec_Sea = record
Rec_Sea:TMySearchRec; // наша структура поиска
path:String[250]; // откуда начинали
found:integer; // при остановке нашли чтото или нет
end;
Второй вопрос после первого решается не очень красиво, но довольно легко. Да система генерит структуру: FindHandle: THandle; FindData: TWin32FindData. FindData - собственно сама структура и FindHandle - указатель на нее. Пусть система генерит что угодно, если с умом, то можно обойти и это. Многие ли помнят такое INT21h->INT 13H. Думаю вспомнили. При восстановлении поиска дадим команду FindFirst, а потом подменим FindData и остальные поля, не трогая FindHandle, иначе сразу после окончания поиска (!!! ???) получим обращение к недопустимому адресу и вылет программы.
……
// создаем запись для поиска
FindFirst(path+’\'+mask, FaAnyfile, sr);
delfile:=false; found:=buffer.found;
// загоняем в SEARCHREC все кроме FINDHANDLE (он создается системой)
sr.Time:=buffer.rec_sea.Time; sr.Size:=buffer.rec_sea.Size;
sr.Attr:=buffer.rec_sea.Attr; sr.Name:=buffer.rec_sea.Name;
sr.ExcludeAttr:=buffer.rec_sea.ExcludeAttr; sr.FindData:=buffer.rec_sea.FindData;
Первый вопрос - как же сохранять состояние процедуры при рекурсии?. Давайте сохранять SearchRec в файл и используем принцип магазина (не продуктового, а от автомата калашникова) - последний вошел - первый вышел. Вот примерная структура процедуры при выполняющемся поиске ( при нескольких рекурсивных вызовах)
Findfile(’c:\’)
Findfile(’c:\Docs’)
FindFile(c:\Docs\Delphi’)
……
При получении сигнала на остановку процедуры начинают писать в файл в обратном порядке, а именно - FindFile(c:\Docs\Delphi’),Findfile(’c:\Docs’),Findfile(’c:\’). Примерно так
Findfile(’c:\’)————————————+
Findfile(’c:\Docs’)———————+ !
FindFile(c:\Docs\Delphi’) —+ ! !
v v v
[файл сохранений состояния] [rec1] [rec2] [rec3]
Ну а когда нужно восстановить состояние поиска смотрим не пустой ли файл сохранений, и читаем записи начиная с конца, после прочтения их удаляем. Таким образом поиск по дереву автоматом развернется на столько рекурсивных вызовов, сколько надо, и продолжит поиск.
Да, едва не забыл, как мы узнаем что надо приостановить поиск ? Давайте заведем глобальную переменную Process. Как она станет False - пора останавливаться
Ниже приведена часть модуля с использованием описанных алгоритмов
Unit unit1;
……
var
….
process:boolean; // вот глобальная переменная она и управляет поиском true - можно
// false - стоп с запоминанием состояния
…..
procedure FileFind(path:string;resume:boolean);
{ сканирует диск (вернее дерево каталогов) при вызове PATH - начальный каталог для обхода
RESUME - если TRUE - то продолжать сохраненный поиск (тогда значение PATH игнорируется,
кроме случая, когда не обнаружен файл сохранения поиска)
при установке глобальной переменной PROCESS в false останавливается
с запоминанием предыдущего состояния,внимание - РЕКУРСИЯ !!! }
const
save_ext=’.rec’; // в каталоге приложения создает SAVE файл с именем приложения и указанным расширением
mask=’*.*’;
type
TMysearchRec = record
// пришлось написать свой тип SEARCHREC с NAME фиксированной длины
Time: Integer; Size: Integer; Attr: Integer;
Name: string[250]; //вот тут обрабатывалось неверно при типе TString, как длина ?
ExcludeAttr: Integer; FindHandle: THandle; FindData: TWin32FindData;
end;
TMyRec_Sea = record
Rec_Sea:TMySearchRec;
path:String[250]; found:integer; delfile:boolean;
end;
var
sr:TSearchRec;
RecFile:TFileStream;
buffer:tMyRec_Sea;
sp,save_file_name:string; found:integer; delfile:Boolean;
delfile:Boolean;
begin
if resume then
// возобновить поиск или начать новый
begin
save_file_name:=ChangeFileExt(ParamStr(0),save_ext);
if FileExists(save_file_name) then
begin
RecFile:=TFileStream.Create(save_file_name,fmOpenReadWrite);
// чистим буфер, не важно, необходимо для отладки
fillchar(buffer,sizeof(buffer),#0);
// читаем сохранение начиная с конца файла
RecFile.Seek(-1*sizeof(buffer),soFromEnd);
RecFile.Readbuffer(buffer,sizeof(buffer));
path:=buffer.path; sp:=path;
// создаем запись для поиска
FindFirst(path+’\'+mask, FaAnyfile, sr);
delfile:=false; found:=buffer.found;
// загоняем в SEARCHREC все кроме FINDHANDLE (он создается системой)
sr.Time:=buffer.rec_sea.Time; sr.Size:=buffer.rec_sea.Size;
sr.Attr:=buffer.rec_sea.Attr; sr.Name:=buffer.rec_sea.Name;
sr.ExcludeAttr:=buffer.rec_sea.ExcludeAttr; sr.FindData:=buffer.rec_sea.FindData;
// режем кусок уже прочитали свои данные - другим они не понадобятся
RecFile.Seek(-1*sizeof(buffer),soFromEnd); recfile.Size:=RecFile.Position;
// дорезались - дозагружаться неоткуда
if RecFile.Size=0 then delfile:=true;
RecFile.Free;
if delfile then sysutils.DeleteFile(save_file_name);
end
else
// нет сохраненных поисков
begin
// начинаем новый
sp:=path; resume:=false;
// тут исправляется разница между C:\ и C:\DOCS - убираем последний слэш
if sp[length(sp)]=’\’ then sp:=copy(sp,1,length(sp)-1);
found:=FindFirst(sp + ‘\’+mask, FaAnyfile, sr);
end
end
else
begin
// новый поиск - пристрелить старые записи
save_file_name:=ChangeFileExt(ParamStr(0),save_ext);
if fileExists(save_file_name) then sysutils.DeleteFile(save_file_name) ;
sp:=path;
if sp[length(sp)]=’\’ then sp:=copy(sp,1,length(sp)-1);
found:=FindFirst(sp + ‘\’+mask, FaAnyfile, sr);
end;
// закончена подготовка - вперед поиск
while (found = 0) and process do
begin
application.ProcessMessages;
if (sr.name <> ‘.’) and (sr.name <> ‘..’) then
begin
if (sr.attr and FaDirectory) = FaDirectory
then
begin
FileFind(sp+’\'+sr.name,resume);
end
else
begin
// ну тут разные действия с найденым файлом
mainform.label1.caption:=(’начат разбор ‘+sp+’\'+sr.name) ;
…………….
// закончили действия
Application.ProcessMessages; // а вот без этого мы никогда не узнаем что пора поиск
// закончить
end;
end;
if process then found:=findnext(sr);
end;
if not process then
// получили сигнал на остановку сканирования нужно запомнить состояние
begin
save_file_name:=ChangeFileExt(ParamStr(0),save_ext);
if not FileExists(save_file_name) then RecFile:=TFileStream.Create(save_file_name,fmCreate)
else RecFile:=TFileStream.Create(save_file_name,fmOpenReadWrite);
RecFile.Seek(0,soFromEnd);
// заполняем буфер текущим состоянием
buffer.rec_sea.Time :=sr.Time; buffer.rec_sea.Size :=sr.Size ;
buffer.rec_sea.Attr :=sr.Attr ; buffer.rec_sea.Name :=sr.Name ;
buffer.rec_sea.ExcludeAttr :=sr.ExcludeAttr ; buffer.rec_sea.FindHandle :=sr.FindHandle ;
buffer.rec_sea.FindData :=sr.FindData ; buffer.path:=sp; buffer.found:=found;
RecFile.Writebuffer(buffer,sizeof(buffer));
RecFile.Free;
end;
Application.ProcessMessages;
sysutils.FindClose(sr);
end;
Декабрь
12,
2007
— Рубрика: Delphi
Метки: возобновление, прерывание
В Windows 2000 и выше, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется “The Taskbar Notification Area”
значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.
Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:
uses Windows;
type
NotifyIconData_50 = packed record // определённая в shellapi.h
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..MAXCHAR] of AnsiChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..MAXBYTE] of AnsiChar;
uTimeout: UINT; // union with uVersion: UINT;
szInfoTitle: array[0..63] of AnsiChar;
dwInfoFlags: DWORD;
end{record};
const
NIF_INFO = $00000010;
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
А это набор вспомогательных типов:
type
TBalloonTimeout = 10..30{seconds};
TBalloonIconType = (bitNone, // нет иконки
bitInfo, // информационная иконка (синяя)
bitWarning, // иконка восклицания (жёлтая)
bitError); // иконка ошибки (красная)
Теперь мы готовы приступить к созданию округлённых подсказок!
Для этого воспользуемся следующей функцией:
uses SysUtils, Windows, ShellAPI;
function BalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: String; const BalloonIconType: TBalloonIconType): Boolean;
const
aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
NID_50 : NotifyIconData_50;
begin
FillChar(NID_50, SizeOf(NotifyIconData_50), 0);
with NID_50 do
begin
cbSize := SizeOf(NotifyIconData_50);
Wnd := Window;
uID := IconID;
uFlags := NIF_INFO;
StrPCopy(szInfo, BalloonText);
uTimeout := Timeout * 1000;
StrPCopy(szInfoTitle, BalloonTitle);
dwInfoFlags := aBalloonIconTypes[BalloonIconType];
end{with};
Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50);
end;
Вызывается она следующим образом:
BalloonTrayIcon(Form1.Handle, 1, 10, ‘this is the balloon text’, ‘title’, bitWarning);
Иконка, должна быть предварительно добавлена с тем же дескриптором окна и IconID (в данном примере Form1.Handle и 1).
Можете попробовать все три типа иконок внутри всплывающей подсказки.
Несколько заключительных замечаний:
1. Нет необходимости использовать большую структуру NotifyIconData_50 для добавления или удаления иконок, старая добрая структура NotifyIconData прекрасно подойдёт для этого.
2. Для callback сообщения можно использовать WM_APP + что-нибудь.
3. Используя различные IconID, легко можно добавить несколько различных иконок из одного родительского окна и работать с ними по их IconID.
Декабрь
10,
2007
— Рубрика: Delphi
Метки: System Tray, значок приложения
Пример показывает, как можно отслеживать практически все события происходящий в Вашей оболочке. Код находится в процессе разработки, но уже содержит в себе большое количество возможностей.
(Источник: “Delphi X-Files” “)
<-------------- Begin UNIT code ---------------------------->
{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
{$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}
unit ShellNotify;
interface
uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
{$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
ShlObj;
type
NOTIFYREGISTER = record
pidlPath : PItemIDList;
bWatchSubtree : boolean;
end;
PNOTIFYREGISTER = ^NOTIFYREGISTER;
const
SNM_SHELLNOTIFICATION = WM_USER +1;
SHCNF_ACCEPT_INTERRUPTS = $0001;
SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
SHCNF_NO_PROXY = $8000;
type
TNotificationEvent = (neAssociationChange, neAttributesChange,
neFileChange, neFileCreate, neFileDelete, neFileRename,
neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,
neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,
neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,
neServerDisconnect, neImageListChange);
TNotificationEvents = set of TNotificationEvent;
TShellNotificationEvent1 = procedure(Sender: TObject;
Path: String)of Object;
TShellNotificationEvent2 = procedure(Sender: TObject;
path1, path2: String) of Object;
// TShellNotificationAttributesEvent = procedure(Sender: TObject;
// OldAttribs, NewAttribs: Integer) of Object;
TShellNotification = class( TComponent )
private
fWatchEvents: TNotificationEvents;
fPath: String;
fActive, fWatch: Boolean;
prevPath1, prevPath2: String;
PrevEvent: Integer;
Handle, NotifyHandle: HWND;
fOnAssociationChange: TNotifyEvent;
fOnAttribChange: TShellNotificationEvent2;
FOnCreate: TShellNotificationEvent1;
FOnDelete: TShellNotificationEvent1;
FOnDriveAdd: TShellNotificationEvent1;
FOnDriveAddGui: TShellNotificationEvent1;
FOnDriveRemove: TShellNotificationEvent1;
FOnMediaInsert: TShellNotificationEvent1;
FOnMediaRemove: TShellNotificationEvent1;
FOnDirCreate: TShellNotificationEvent1;
FOnNetShare: TShellNotificationEvent1;
FOnNetUnShare: TShellNotificationEvent1;
FOnRenameFolder: TShellNotificationEvent2;
FOnItemRename: TShellNotificationEvent2;
FOnFolderRemove: TShellNotificationEvent1;
FOnServerDisconnect: TShellNotificationEvent1;
FOnFolderUpdate: TShellNotificationEvent1;
function PathFromPidl(Pidl: PItemIDList): String;
procedure SetWatchEvents(const Value: TNotificationEvents);
function GetActive: Boolean;
procedure SetActive(const Value: Boolean);
procedure SetPath(const Value: String);
procedure SetWatch(const Value: Boolean);
protected
procedure ShellNotifyRegister;
procedure ShellNotifyUnregister;
procedure WndProc(var Message: TMessage);
procedure DoAssociationChange; dynamic;
procedure DoAttributesChange(Path1, Path2: String); dynamic;
procedure DoCreateFile(Path: String); dynamic;
procedure DoDeleteFile(Path: String); dynamic;
procedure DoDriveAdd(Path:String); dynamic;
procedure DoDriveAddGui(Path: String); dynamic;
procedure DoDriveRemove(Path: String); dynamic;
procedure DoMediaInsert(Path: String); dynamic;
procedure DoMediaRemove(Path: String); dynamic;
procedure DoDirCreate(Path: String); dynamic;
procedure DoNetShare(Path: String); dynamic;
procedure DoNetUnShare(Path: String); dynamic;
procedure DoRenameFolder(Path1, Path2: String); dynamic;
procedure DoRenameItem(Path1, Path2: String); dynamic;
procedure DoFolderRemove(Path: String); dynamic;
procedure DoServerDisconnect(Path: String); dynamic;
procedure DoDirUpdate(Path: String); dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Path: String read fPath write SetPath;
property Active: Boolean read GetActive write SetActive;
property WatchSubTree: Boolean read fWatch write SetWatch;
property WatchEvents: TNotificationEvents
read fWatchEvents write SetWatchEvents;
property OnAssociationChange: TNotifyEvent
read fOnAssociationChange write FOnAssociationChange;
property OnAttributesChange: TShellNotificationEvent2
read fOnAttribChange write fOnAttribChange;
property OnFileCreate: TShellNotificationEvent1
read FOnCreate write FOnCreate;
property OnFolderRename: TShellNotificationEvent2
read FOnRenameFolder write FOnRenameFolder;
property OnFolderUpdate: TShellNotificationEvent1
read FOnFolderUpdate write FOnFolderUpdate;
property OnFileDelete: TShellNotificationEvent1
read FOnDelete write FOnDelete;
property OnDriveAdd: TShellNotificationEvent1
read FOnDriveAdd write FOnDriveAdd;
property OnFolderRemove: TShellNotificationEvent1
read FOnFolderRemove write FOnFolderRemove;
property OnItemRename: TShellNotificationEvent2
read FOnItemRename write FOnItemRename;
property OnDriveAddGui: TShellNotificationEvent1
read FOnDriveAddGui write FOnDriveAddGui;
property OnDriveRemove: TShellNotificationEvent1
read FOnDriveRemove write FOnDriveRemove;
property OnMediaInserted: TShellNotificationEvent1
read FOnMediaInsert write FOnMediaInsert;
property OnMediaRemove: TShellNotificationEvent1
read FOnMediaRemove write FOnMediaRemove;
property OnDirCreate: TShellNotificationEvent1
read FOnDirCreate write FOnDirCreate;
property OnNetShare: TShellNotificationEvent1
read FOnNetShare write FOnNetShare;
property OnNetUnShare: TShellNotificationEvent1
read FOnNetUnShare write FOnNetUnShare;
property OnServerDisconnect: TShellNotificationEvent1
read FOnServerDisconnect write FOnServerDisconnect;
end;
function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;
wEventMask : cardinal; uMsg: UINT; cItems : integer;
lpItems : PNOTIFYREGISTER) : HWND; stdcall;
function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;
function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;
var Attributes: ULONG):HResult; stdcall;
implementation
const Shell32DLL = ’shell32.dll’;
function SHChangeNotifyRegister; external Shell32DLL index 2;
function SHChangeNotifyDeregister; external Shell32DLL index 4;
function SHILCreateFromPath; external Shell32DLL index 28;
{ TShellNotification }
constructor TShellNotification.Create(AOwner: TComponent);
begin
inherited Create( AOwner );
if not (csDesigning in ComponentState) then
Handle := AllocateHWnd(WndProc);
end;
destructor TShellNotification.Destroy;
begin
if not (csDesigning in ComponentState) then
Active := False;
if Handle <> 0 then DeallocateHWnd( Handle );
inherited Destroy;
end;
procedure TShellNotification.DoAssociationChange;
begin
if Assigned( fOnAssociationChange ) and (neAssociationChange in fWatchEvents) then
fOnAssociationChange( Self );
end;
procedure TShellNotification.DoAttributesChange;
begin
if Assigned( fOnAttribChange ) then
fOnAttribChange( Self, Path1, Path2 );
end;
procedure TShellNotification.DoCreateFile(Path: String);
begin
if Assigned( fOnCreate ) then
FOnCreate(Self, Path)
end;
procedure TShellNotification.DoDeleteFile(Path: String);
begin
if Assigned( FOnDelete ) then
FOnDelete(Self, Path);
end;
procedure TShellNotification.DoDirCreate(Path: String);
begin
if Assigned( FOnDirCreate ) then
FOnDirCreate( Self, Path );
end;
procedure TShellNotification.DoDirUpdate(Path: String);
begin
if Assigned( FOnFolderUpdate ) then
FOnFolderUpdate(Self, Path);
end;
procedure TShellNotification.DoDriveAdd(Path: String);
begin
if Assigned( FOnDriveAdd ) then
FOnDriveAdd(Self, Path);
end;
procedure TShellNotification.DoDriveAddGui(Path: String);
begin
if Assigned( FOnDriveAddGui ) then
FOnDriveAdd(Self, Path);
end;
procedure TShellNotification.DoDriveRemove(Path: String);
begin
if Assigned( FOnDriveRemove ) then
FOnDriveRemove(Self, Path);
end;
procedure TShellNotification.DoFolderRemove(Path: String);
begin
if Assigned(FOnFolderRemove) then
FOnFolderRemove( Self, Path );
end;
procedure TShellNotification.DoMediaInsert(Path: String);
begin
if Assigned( FOnMediaInsert ) then
FOnMediaInsert(Self, Path);
end;
procedure TShellNotification.DoMediaRemove(Path: String);
begin
if Assigned(FOnMediaRemove) then
FOnMediaRemove(Self, Path);
end;
procedure TShellNotification.DoNetShare(Path: String);
begin
if Assigned(FOnNetShare) then
FOnNetShare(Self, Path);
end;
procedure TShellNotification.DoNetUnShare(Path: String);
begin
if Assigned(FOnNetUnShare) then
FOnNetUnShare(Self, Path);
end;
procedure TShellNotification.DoRenameFolder(Path1, Path2: String);
begin
if Assigned( FOnRenameFolder ) then
FOnRenameFolder(Self, Path1, Path2);
end;
procedure TShellNotification.DoRenameItem(Path1, Path2: String);
begin
if Assigned( FOnItemRename ) then
FonItemRename(Self, Path1, Path2);
end;
procedure TShellNotification.DoServerDisconnect(Path: String);
begin
if Assigned( FOnServerDisconnect ) then
FOnServerDisconnect(Self, Path);
end;
function TShellNotification.GetActive: Boolean;
begin
Result := (NotifyHandle <> 0) and (fActive);
end;
function TShellNotification.PathFromPidl(Pidl: PItemIDList): String;
begin
SetLength(Result, Max_Path);
if not SHGetPathFromIDList(Pidl, PChar(Result)) then Result := ”;
if pos(#0, Result) > 0 then
SetLength(Result, pos(#0, Result));
end;
procedure TShellNotification.SetActive(const Value: Boolean);
begin
if (Value <> fActive) then
begin
fActive := Value;
if fActive then ShellNotifyRegister else ShellNotifyUnregister;
end;
end;
procedure TShellNotification.SetPath(const Value: String);
begin
if fPath <> Value then
begin
fPath := Value;
ShellNotifyRegister;
end;
end;
procedure TShellNotification.SetWatch(const Value: Boolean);
begin
if fWatch <> Value then
begin
fWatch := Value;
ShellNotifyRegister;
end;
end;
procedure TShellNotification.SetWatchEvents(
const Value: TNotificationEvents);
begin
if fWatchEvents <> Value then
begin
fWatchEvents := Value;
ShellNotifyRegister;
end;
end;
procedure TShellNotification.ShellNotifyRegister;
var
NotifyRecord: PNOTIFYREGISTER;
Flags: DWORD;
Pidl: PItemIDList;
Attributes: ULONG;
begin
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState) then
begin
SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);
NotifyRecord^.pidlPath := Pidl;
NotifyRecord^.bWatchSubtree := fWatch;
if NotifyHandle <> 0 then ShellNotifyUnregister;
Flags := 0;
if neAssociationChange in FWatchEvents then
Flags := Flags or SHCNE_ASSOCCHANGED;
if neAttributesChange in FWatchEvents then
Flags := Flags or SHCNE_ATTRIBUTES;
if neFileChange in FWatchEvents then
Flags := Flags or SHCNE_UPDATEITEM;
if neFileCreate in FWatchEvents then
Flags := Flags or SHCNE_CREATE;
if neFileDelete in FWatchEvents then
Flags := Flags or SHCNE_DELETE;
if neFileRename in FWatchEvents then
Flags := Flags or SHCNE_RENAMEITEM;
if neDriveAdd in FWatchEvents then
Flags := Flags or SHCNE_DRIVEADD;
if neDriveRemove in FWatchEvents then
Flags := Flags or SHCNE_DRIVEREMOVED;
if neShellDriveAdd in FWatchEvents then
Flags := Flags or SHCNE_DRIVEADDGUI;
if neDriveSpaceChange in FWatchEvents then
Flags := Flags or SHCNE_FREESPACE;
if neMediaInsert in FWatchEvents then
Flags := Flags or SHCNE_MEDIAINSERTED;
if neMediaRemove in FWatchEvents then
Flags := Flags or SHCNE_MEDIAREMOVED;
if neFolderCreate in FWatchEvents then
Flags := Flags or SHCNE_MKDIR;
if neFolderDelete in FWatchEvents then
Flags := Flags or SHCNE_RMDIR;
if neFolderRename in FWatchEvents then
Flags := Flags or SHCNE_RENAMEFOLDER;
if neFolderUpdate in FWatchEvents then
Flags := Flags or SHCNE_UPDATEDIR;
if neNetShare in FWatchEvents then
Flags := Flags or SHCNE_NETSHARE;
if neNetUnShare in FWatchEvents then
Flags := Flags or SHCNE_NETUNSHARE;
if neServerDisconnect in FWatchEvents then
Flags := Flags or SHCNE_SERVERDISCONNECT;
if neImageListChange in FWatchEvents then
Flags := Flags or SHCNE_UPDATEIMAGE;
NotifyHandle := SHChangeNotifyRegister(Handle,
SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,
Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);
end;
end;
procedure TShellNotification.ShellNotifyUnregister;
begin
if NotifyHandle <> 0 then
SHChangeNotifyDeregister(NotifyHandle);
end;
procedure TShellNotification.WndProc(var Message: TMessage);
type
TPIDLLIST = record
pidlist : array[1..2] of PITEMIDLIST;
end;
PIDARRAY = ^TPIDLLIST;
var
Path1 : string;
Path2 : string;
ptr : PIDARRAY;
repeated : boolean;
event : longint;
begin
case Message.Msg of
SNM_SHELLNOTIFICATION:
begin
event := Message.LParam and ($7FFFFFFF);
Ptr := PIDARRAY(Message.WParam);
Path1 := PathFromPidl( Ptr^.pidlist[1] );
Path2 := PathFromPidl( Ptr^.pidList[2] );
repeated := (PrevEvent = event)
and (uppercase(prevpath1) = uppercase(Path1))
and (uppercase(prevpath2) = uppercase(Path2));
if Repeated then exit;
PrevEvent := Message.Msg;
prevPath1 := Path1;
prevPath2 := Path2;
case event of
SHCNE_ASSOCCHANGED : DoAssociationChange;
SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);
SHCNE_CREATE : DoCreateFile(Path1);
SHCNE_DELETE : DoDeleteFile(Path1);
SHCNE_DRIVEADD : DoDriveAdd(Path1);
SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);
SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);
SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);
SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);
SHCNE_MKDIR : DoDirCreate(Path1);
SHCNE_NETSHARE : DoNetShare(Path1);
SHCNE_NETUNSHARE : DoNetUnShare(Path1);
SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);
SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);
SHCNE_RMDIR : DoFolderRemove(Path1);
SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);
SHCNE_UPDATEDIR : DoDirUpdate(Path);
SHCNE_UPDATEIMAGE : ;
SHCNE_UPDATEITEM : ;
end;//Case event of
end;//SNM_SHELLNOTIFICATION
end; //case
end;
end.
Декабрь
1,
2007
— Рубрика: Delphi
Метки: Delphi, Windows, события
Часто программисту приходится сталкиваться с задачей написания приложения, работающего в фоновом режиме и не нуждающегося в месте на Панели задач. Если вы посмотрите на правый нижний угол рабочего стола Windows, то наверняка найдете там приложения, для которых эта проблема решена: часы, переключатель раскладок клавиатуры, регулятор громкости и т. п. Ясно, что, как бы вы не увеличивали и не уменьшали формы своего приложения, попасть туда обычным путем не удастся. Способ для этого предоставляет Shell API.
Те картинки, которые находятся на System Tray — это действительно просто картинки, а не свернутые окна. Они управляются и располагаются панелью System Tray. Она же берет на себя еще две функции: показ подсказки для каждого из значков и оповещение приложения, создавшего значок, обо всех перемещениях мыши над ним.
Весь API System Tray состоит из 1 (одной) функции:
function Shell_NotifyIcon(dwMessage: DWORD;
IpData: PNotifylconData): BOOL; PNotifylconData = TNotifylconData; TNotifylconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hlcon: HICON;
szTip: array [0..63] of AnsiChar;
end;
Параметр dwMessage определяет одну из операций: NIM_ADD означает добавление значка в область, NIM_DELETE — удаление, NIM_MODIFY — изменение.
Ход операции зависит от того, какие поля структуры TNotifyiconData будут заполнены.
Обязательным для заполнения является поле cbsize — там содержится размер структуры. Поле wnd должно содержать дескриптор окна, которое будет оповещаться о событиях, связанных со значком. Идентификатор сообщения Windows, которое вы хотите получать от системы о перемещениях мыши над значком, запишите в поле uCallbackMessage. Если вы хотите, чтобы при этих перемещениях над вашим значком показывалась подсказка, то задайте ее текст в поле szTip. В поле UID задается номер значка — каждое приложение может поместить на System Tray сколько угодно значков. Дальнейшие операции вы будете производить, задавая этот номер. Дескриптор помещаемого значка должен быть задан в поле hIcon. Здесь вы можете задать значок, связанный с вашим приложением, или загрузить свой — из ресурсов.
Примечание
Изменить главный значок приложения можно в диалоговом окне Project/ Options на странице Application. Он будет доступен через свойство Application.Icon. Тут же можно отредактировать и строку для подсказки — свойство Application.Title.
Наконец, в поле uFlags вы должны сообщить системе, что именно вы от нее хотите, или, другими словами, какие из полей hicon, uCaiibackMessage и szTip вы на самом деле заполнили. В этом поле предусмотрена комбинация трех флагов: NIF_ICON, NIF_MESSAGE и NIF_TIP. Вы можете заполнить, скажем, поле szTip, но если вы при этом не установили флаг NIF_TIP, созданный вами значок не будет иметь строки с подсказкой.
Два приведенных ниже метода иллюстрируют сказанное. Первый из них создает значок на System Tray, а второй — уничтожает его.
const WM_MYTRAYNOTIFY = WMJJSER + 123;
procedure TForml.CreateTraylcon(n:Integer);
var nidata : TNotifyiconData;
begin
with nidata do
begin
cbSize := SizeOf{TNotifyiconData) ;
Wnd := Self.Handle;
uID := n;
uFiags := NIF_ICON or NIF_MESSAGE or NIFJTIP;
uCallBackMessage := WM_MYTRAYNOTIFY;
hicon := Application.Icon.Handle;
szTip := ‘THis is Traylcon Example’;
end;
Shell_NotifyIcon(NIM_ADD, @nidata);
end;
procedure TForml.DeleteTraylcon(n:Integer);
var nidata : TNotifylconData; begin
with nidata do
begin
cbSize := SizeOf(TNotifylconData);
Wnd := Self.Handle; uID := n; end;
Shell_NotifyIcon(NIM_DELETE, @nidata);
end;
Примечание:
He забывайте уничтожать созданные вами значки на System Tray. Это не делается автоматически даже при закрытии приложения. Значок будет удален только после перезагрузки системы.
Внешний вид значка, помещенного нами на System Tray, ничем не отличается от значков других приложений (рис. 31.1).
[]
Рис. 31.1. Над значком, помещенным на панель System Tray, видна строка подсказки
Сообщение, задаваемое в поле uCallbackMessage, по сути дела является единственной ниточкой, связывающей вас со значком после его создания. Оно объединяет в себе несколько сообщений. Когда к вам пришло такое сообщение (в примере, рассмотренном выше, оно имеет идентификатор WM_MYTRAYNOTIFY), поля в переданной в обработчик структуре типа TMessage распределены так. Параметр wParam содержит номер значка (тот самый, что задавался в поле uID при его создании), а параметр LParam — идентификатор сообщения от мыши, вроде WM_MOUSEMOVE, WM_LBUTTONDOWN и т. п. К сожалению, остальная информация из этих сообщений теряется. Координаты мыши в момент события придется узнать, вызвав функцию API GetCursorPos:
procedure TForml.WMICON(var msg: TMessage);
var P : TPoint; begin case msg.LParam of
WM_LBUTTONDOWN:
begin
GetCursorPos(p);
SetForegroundWindow(Application.MainForm.Handle); PopupMenul.Popup(P.X, P.Y);
end;
WM_LBUTTONUP :
end;
end;
Обратите внимание, что при показе всплывающего меню недостаточно просто вызвать метод Popup. При этом нужно вынести главную форму приложения на передний план, в противном случае она не получит сообщений от меню.
Теперь решим еще две задачи. Во-первых, как сделать, чтобы приложение минимизировалось не на Панель задач (TaskBar), а на System Tray? И более того — как сразу запустить его в минимизированном виде, а показывать главную форму только по наступлении определенного события (приходу почты, наступлению определенного времени и т. п.).
Ответ на первый вопрос очевиден. Если минимизировать не только окно главной формы приложения (Application.MainForm.Handle), но и окно приложения (Application.Handle), то приложение полностью исчезнет “с экранов радаров”. В этот самый момент нужно создать значок на панели System Tray. В его всплывающем меню должен быть пункт, при выборе которого оба окна восстанавливаются, а значок удаляется.
Чтобы приложение запустилось сразу в минимизированном виде и без главной формы, следует к вышесказанному добавить установку свойства Application.showMainForm в значение False. Здесь возникает одна сложность — если главная форма создавалась в невидимом состоянии, ее компоненты будут также созданы невидимыми. Поэтому при первом ее показе установим их свойство visible в значение True. Чтобы не повторять это дважды, установим флаг — глобальную переменную shownonce:
procedure TForml.HideMainForm;
begin
Appiication.showMainForm := False;
ShowWindow(Application.Handle, SW_HIDE);
ShowWindow(Application.MainForm.Handle, SW_HIDE);
end;
procedure TForml.RestoreMainForm;
var i,j : Integer;
begin
Appiication.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 TForml.WMSYSCOMMAND(var msg: TMessage);
begin inherited;
if (Msg.wParam=SC_MINIMIZE) then
begin
HideMainForm; CreateTraylcon(l) ;
end;
end;
procedure TForml.FileOpenltemlClick(Sender: TObject); begin
RestoreMainForm;
DeleteTraylcon(l);
end;
Теперь у вас в руках полноценный набор средств для работы с панелью System Tray. В заключение необходимо добавить, что все описанное реализуется не в операционной системе, а в оболочке ОС — Проводнике (Explorer). В принципе, и Windows NT 4/2000, и Windows 95/98 допускают замену оболочки ОС на другие, например DashBoard или LightStep. Там функции панели System Tray могут быть не реализованы или реализованы через другие API. Впрочем, случаи замены оболочки достаточно редки.
Ноябрь
30,
2007
— Рубрика: Delphi
Метки: System Tray, значок приложения
Немного о непрямоугольных формах… Кажется, весь мир сошёл с ума по таким формам; все форумы пестрят вопросами на эту тему Есть ли сложности при создании непрямоугольной формы? Нет… Почти… Дело в том, что задать внешний вид формы можно, вызвав всего лишь одну функцию SetWindowsRgn.
SetWindowsRgn(Form1.Handle, True);
Правда, перед этим потребуется создать подходящий регион. Большинство из тех, кто работает на Delphi, не знают, что такое регион, главным образом потому, что эта штука не нашла своего отражения в VCL.
Документация утверждает, что регион, это “прямоугольник, многоугольник, эллипс или комбинация двух или более фигур из приведённого списка”. Регионы используются для “заливки, отсечения (то, что по английски называется clipping)” и других, не менее полезных операций.
Для создания регионов существуют такие функции (с очевидным назначением), как CreateRectRgn, CreateEllipticRgn, CreatePolygonRgn и несколько других. Объединять регионы между собой можно при помощи функции CombineRgn.
На этом теоретическая часть могла бы быть закончена, если бы не одно “но”… Это “но” я процитирую отдельно…
Но ведь чаще всего непрямоугольную форму требуется построить на базе растровой картинки, задав для неё прозрачный цвет! Как быть?
Это правда. Насколько мне известно, Windows не умеет этого делать, то есть в ней нет функции CreateBitmapRgn. Тем не менее, можно создавать и такие регионы. Для этого необходимо пробежаться по всей картинке сверху вниз, в каждой строчке найти непрозрачные области и сделать из них прямоугольные регионы (эти прямоугольники будут высотой в 1 пиксель). Затем мы объединяем эти регионы — и, вуаля — вот он, искомый регион!
Готов поспорить, вы думаете, что это слишком сложно… Проверяем…
function BitmapToRegion(Bitmap: TBitmap; TransColor: TColor): HRGN;
var
X, Y: Integer;
XStart: Integer;
begin
Result := 0;
with Bitmap do
for Y := 0 to Height - 1 do
begin
X := 0;
while X < Width do
begin
// Пропускаем прозрачные точки
while (X < Width) and (Canvas.Pixels[X, Y] = TransColor) do
Inc(X);
if X >= Width then
Break;
XStart := X;
// Пропускаем непрозрачные точки
while (X < Width) and (Canvas.Pixels[X, Y] <> TransColor) do
Inc(X);
// Создаём новый прямоугольный регион и добавляем его к
// региону всей картинки
if Result = 0 then
Result := CreateRectRgn(XStart, Y, X, Y + 1)
else
CombineRgn(Result, Result,
CreateRectRgn(XStart, Y, X, Y + 1), RGN_OR);
end;
end;
end;
Этот способ работает, конечно, небыстро, но он работает. Помимо всего прочего, посмотрим, как таскать форму левой кнопкой мыши (в смысле, не только за заголовок окна). Для этого нам потребуется создать свою собственную процедуру обработки события WM_LBUTTONDOWN, которое форма получает всякий раз, когда на ней нажимают левую кнопку мыши. Вот как эта процедура выглядит в описании формы:
type
TFormMain = class(TForm)
private
{ Private declarations }
procedure WMLButtonDown(var Msg: TMessage); message WM_LBUTTONDOWN;
public
{ Public declarations }
end;
Строка, которую нужно добавить, выделена красным цветом. В разделе реализации эта функция выглядит так:
procedure TFormMain.WMLButtonDown(var Msg: TMessage);
begin
Perform(WM_NCLBUTTONDOWN, HTCAPTION, Msg.LParam);
end;
Форма посылает самой себе сообщение WM_NCLBUTTONDOWN с wParam равным HTCAPTION, то есть эмулирует ситуацию, когда пользователь нажимает левую кнопку мыши на заголовке формы. После этого форму можно спокойно перемещать за всю её область.
Как видите, ничего сложного в создании непрямоугольных окон. Такие окна подчёркивают выразительность программы и показывают профессионализм её создателя…
Ноябрь
29,
2007
— Рубрика: Delphi
Метки: Delphi, непрямоугольные формы
