На свой процесс я всегда создаю один экземпляр 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, события
