/examples/trayicon/frmtest.pas

http://github.com/graemeg/lazarus · Pascal · 158 lines · 89 code · 26 blank · 43 comment · 1 complexity · 6b75953c218947ccdcad66e69c0a035d MD5 · raw file

  1. {
  2. frmtest.dpr
  3. *****************************************************************************
  4. * *
  5. * This demonstration program is public domain, which means no copyright, *
  6. * but also no warranty! *
  7. * *
  8. * This program is distributed in the hope that it will be useful, *
  9. * but WITHOUT ANY WARRANTY; without even the implied warranty of *
  10. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
  11. * *
  12. *****************************************************************************
  13. Author: Felipe Monteiro de Carvalho
  14. }
  15. unit frmtest;
  16. {$ifdef fpc}
  17. {$mode delphi}{$H+}
  18. {$endif}
  19. interface
  20. uses
  21. Classes, SysUtils,
  22. {$ifdef fpc}
  23. LResources,
  24. {$endif}
  25. Forms, Controls, Graphics, Dialogs, Buttons, StdCtrls, Menus,
  26. ExtCtrls;
  27. type
  28. { TfrmTrayTest }
  29. TfrmTrayTest = class(TForm)
  30. btnShow: TButton;
  31. btnHide: TButton;
  32. btnDisplayMessage: TButton;
  33. chkOnPaintDrawing: TCheckBox;
  34. MenuItem1: TMenuItem;
  35. MenuItem2: TMenuItem;
  36. MenuItem3: TMenuItem;
  37. PopupMenu: TPopupMenu;
  38. SystrayIcon: TTrayIcon;
  39. procedure btnShowClick(Sender: TObject);
  40. procedure btnHideClick(Sender: TObject);
  41. procedure chkOnPaintDrawingChange(Sender: TObject);
  42. procedure FormCreate(Sender: TObject);
  43. procedure FormPaint(Sender: TObject);
  44. procedure HandleClick(Sender: TObject);
  45. private
  46. { private declarations }
  47. pathMedia: string;
  48. public
  49. { public declarations }
  50. end;
  51. var
  52. frmTrayTest: TfrmTrayTest;
  53. implementation
  54. {$ifdef fpc}
  55. {$R frmtest.lfm}
  56. {$else}
  57. {$R frmtest.dfm}
  58. {$endif}
  59. {$ifdef Windows}
  60. uses Windows;
  61. {$endif}
  62. {$IFDEF Darwin}
  63. uses
  64. MacOSAll;
  65. {$ENDIF}
  66. { TfrmTrayTest }
  67. procedure TfrmTrayTest.btnShowClick(Sender: TObject);
  68. begin
  69. SystrayIcon.Visible := True;
  70. end;
  71. procedure TfrmTrayTest.btnHideClick(Sender: TObject);
  72. begin
  73. SystrayIcon.Visible := False;
  74. end;
  75. procedure TfrmTrayTest.chkOnPaintDrawingChange(Sender: TObject);
  76. begin
  77. Invalidate;
  78. end;
  79. procedure TfrmTrayTest.FormCreate(Sender: TObject);
  80. const
  81. IDI_ICON1 = 101;
  82. IDI_ICON2 = 115;
  83. BundleResourceFolder = '/Contents/Resources/';
  84. {$IFDEF Darwin}
  85. var
  86. pathRef: CFURLRef;
  87. pathCFStr: CFStringRef;
  88. pathStr: shortstring;
  89. {$ENDIF}
  90. begin
  91. pathMedia := '';
  92. // Under Mac OS X we need to get the location of the bundle
  93. {$IFDEF Darwin}
  94. pathRef := CFBundleCopyBundleURL(CFBundleGetMainBundle());
  95. pathCFStr := CFURLCopyFileSystemPath(pathRef, kCFURLPOSIXPathStyle);
  96. CFStringGetPascalString(pathCFStr, @pathStr, 255, CFStringGetSystemEncoding());
  97. CFRelease(pathRef);
  98. CFRelease(pathCFStr);
  99. pathMedia := pathStr + BundleResourceFolder;
  100. {$ENDIF}
  101. // Under Windows we get the path of the executable
  102. {$IFDEF Windows}
  103. pathMedia := ExtractFilePath(Application.ExeName);
  104. {$ENDIF}
  105. IncludeTrailingBackslash(pathMedia);
  106. SystrayIcon.Hint := 'my tool tip';
  107. SystrayIcon.OnClick := HandleClick;
  108. SystrayIcon.PopUpMenu := PopupMenu;
  109. end;
  110. procedure TfrmTrayTest.FormPaint(Sender: TObject);
  111. var
  112. BaseImage: TIcon;
  113. begin
  114. if chkOnPaintDrawing.Checked then
  115. begin
  116. BaseImage := TIcon.Create;
  117. try
  118. // Loads the icon
  119. BaseImage.LoadFromFile(pathMedia + 'icon.ico');
  120. Canvas.Draw(0, 0, BaseImage);
  121. finally
  122. BaseImage.Free;
  123. end;
  124. end;
  125. end;
  126. procedure TfrmTrayTest.HandleClick(Sender: TObject);
  127. begin
  128. Application.MessageBox('Text', 'Caption', 0);
  129. end;
  130. end.