Экспертная система Delphi.int.ru

Сообщество программистов
Общение, помощь, обмен опытом
Логин:
Пароль:
Регистрация | Забыли пароль?

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

#   

Статистика за сегодня:  


Лучшие эксперты

Подробнее »

Вопрос # 3 752

Раздел: Delphi » Общие вопросы по программированию
/ вопрос открыт /

Доброго времени суток, уважаемые эксперты!

Подскажите, пожалуйста, как анимировать иконку в системном трее ?
Где и что нужно добавить или исправит в коде ?

К вопросу прикреплён файл. Загрузить » (срок хранения: 60 дней с момента отправки вопроса)

Приложение:
  1. program Project1;
  2.  
  3. uses
  4. Forms,
  5. Unit1 in 'Unit1.pas' {Form1},
  6. StopTwoCopyExe in 'StopTwoCopyExe.pas';
  7.  
  8. {$R *.res}
  9. const
  10. UniqueString = 'Form1';
  11.  
  12.  
  13. begin
  14. if not init_mutex(UniqueString) then
  15.  
  16. begin
  17. Application.Initialize;
  18. Application.CreateForm(TForm1, Form1);
  19. Application.ShowMainForm:=False;
  20. Application.Run;
  21. end;
  22. end
  23.  
  24. /////////////////////////////////////////////////////////////////////////////////////////////
  25.  
  26. unit StopTwoCopyExe;
  27.  
  28. interface
  29.  
  30. function Init_Mutex(mid: string): boolean;
  31.  
  32. implementation
  33.  
  34. uses Windows;
  35.  
  36. var
  37. mut: thandle;
  38.  
  39. function mut_id(s: string): string;
  40. var
  41. f: integer;
  42. begin
  43. result := s;
  44. for f := 1 to length(s) do
  45. if result[f] = '' then
  46. result[f] := '_';
  47. end;
  48.  
  49. function Init_Mutex(mid: string): boolean;
  50. begin
  51. Mut := CreateMutex(nil, false, pchar(mut_id(mid)));
  52. Result := not ((Mut = 0) or (GetLastError = ERROR_ALREADY_EXISTS));
  53. end;
  54.  
  55. initialization
  56. mut := 0;
  57. finalization
  58. if mut <> 0 then
  59. CloseHandle(mut);
  60. end.
  61.  
  62. /////////////////////////////////////////////////////////////////////////////////////////////
  63.  
  64. unit Unit1;
  65.  
  66. interface
  67.  
  68. uses
  69. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  70. Dialogs, ImgList, Menus, ExtCtrls,ShellApi, StdCtrls;
  71.  
  72. type
  73. TForm1 = class(TForm)
  74. ImageList1: TImageList;
  75. Timer1: TTimer;
  76. PopupMenu1: TPopupMenu;
  77. Form11: TMenuItem;
  78. Exit1: TMenuItem;
  79. Button1: TButton;
  80. procedure FormCreate(Sender: TObject);
  81. procedure Timer1Timer(Sender: TObject);
  82. procedure FormClose(Sender: TObject; var Action: TCloseAction);
  83. procedure Exit1Click(Sender: TObject);
  84. procedure PopupMenu1Popup(Sender: TObject);
  85. procedure Form11Click(Sender: TObject);
  86. procedure Button1Click(Sender: TObject);
  87.  
  88. private
  89. procedure WMSysCommand(var Msg: TWMSysCommand);message WM_SYSCOMMAND;
  90. { Private declarations }
  91. public
  92.  
  93.  
  94. procedure IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100;
  95. { Public declarations }
  96. end;
  97.  
  98. var
  99. Form1: TForm1;
  100. iconindex : Integer;
  101. implementation
  102.  
  103. {$R *.dfm}
  104.  
  105. procedure TForm1.WMSysCommand;
  106. begin
  107. if Msg.CmdType = SC_MINIMIZE
  108. then
  109.  
  110. Form1.Hide
  111. else
  112. inherited;
  113. end;
  114.  
  115. procedure TForm1.FormCreate(Sender: TObject);
  116. var
  117. nid : TNotifyIconData;
  118. begin
  119.  
  120.  
  121. with nid do
  122. begin
  123.  
  124. cbSize := SizeOf( TNotifyIconData );
  125.  
  126.  
  127. Wnd := Form1.Handle;
  128.  
  129. uID := 0;
  130.  
  131.  
  132. uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
  133.  
  134.  
  135. uCallbackMessage := WM_USER + 100;
  136. StrPCopy(szTip,'Form1');
  137.  
  138.  
  139. hIcon := Application.Icon.Handle;
  140. end;
  141.  
  142. Shell_NotifyIcon( NIM_ADD, @nid );
  143. end;
  144.  
  145. procedure TForm1.Timer1Timer(Sender: TObject);
  146. begin
  147.  
  148. ImageList1.GetIcon(iconindex, Application.Icon);
  149. iconindex := iconindex + 1;
  150. if iconindex > 1
  151. then
  152. iconindex := 0;
  153. end;
  154.  
  155. procedure TForm1.PopupMenu1Popup(Sender: TObject);
  156. begin
  157. SetForegroundWindow(Form1.Handle);
  158. end;
  159.  
  160. procedure TForm1.IconCallBackMessage( var Mess : TMessage );
  161. begin
  162. case Mess.lParam of
  163.  
  164. WM_RBUTTONUP : Form1.PopupMenu1.Popup(Mouse.CursorPos.x, Mouse.CursorPos.y);
  165. end;
  166. end;
  167.  
  168. procedure TForm1.Form11Click(Sender: TObject);
  169. begin
  170.  
  171. Form1.Show;
  172. Form1.Activate;
  173. ShowWindow(Application.Handle, SW_HIDE);
  174. end;
  175.  
  176. procedure TForm1.Exit1Click(Sender: TObject);
  177. begin
  178. Form1.Close
  179. end;
  180.  
  181. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  182. var
  183. nid : TNotifyIconData;
  184. begin
  185. with nid do
  186. begin
  187.  
  188.  
  189.  
  190.  
  191. cbSize := SizeOf( TNotifyIconData );
  192. Wnd := Form1.Handle;
  193. uID := 0;
  194. uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
  195. uCallbackMessage := WM_USER + 100;
  196. hIcon := Application.Icon.Handle;
  197. end;
  198. Shell_NotifyIcon( NIM_DELETE, @nid );
  199. end;
  200.  
  201. procedure TForm1.Button1Click(Sender: TObject);
  202. begin
  203. Form1.Close
  204. end;
  205.  
  206. end.
  207.  


Kyran29 Вопрос ожидает решения (принимаются ответы, доступен мини-форум)

Вопрос задал: Kyran29 (статус: Посетитель)
Вопрос отправлен: 10 февраля 2010, 01:37
Состояние вопроса: открыт, ответов: 0.


Мини-форум вопроса

Всего сообщений: 1; последнее сообщение — 10 февраля 2010, 08:12; участников в обсуждении: 1.
min@y™

min@y™ (статус: Доктор наук), 10 февраля 2010, 08:12 [#1]:

Код не читал, т.к. он без подсветки и форматирования.
Советую выкинуть его совсем, особенно, если не понимаешь, что этот код делает, и юзать компонент TCoolTrayIcon. Если по каким-то причинам заюзать этот компонент нельзя, то внимательно кури интернет.
Делаю лабы и курсачи по Delphi и Turbo Pascal. За ПИВО! Пишите в личку, а лучше в аську. А ещё лучше - звоните в скайп!

Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.
Версия движка: 2.6+ (26.01.2011)
© 2005-2025
Текущее время: 31 октября 2025, 07:19
Выполнено за 0.03 сек.