home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / desktop / hotkey / hotkey95.exe / Source / Components / AniTray.pas < prev    next >
Pascal/Delphi Source File  |  1998-02-10  |  12KB  |  361 lines
  1. unit AniTray;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus,
  7.   WComp, ExtCtrls, ShellAPI, AboutPrp, AniIcons;
  8.  
  9. type
  10.   TTIMouseEvent = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState) of object;
  11.   TTIMouseMove  = TNotifyEvent;
  12.  
  13.   TTrayIconStyle = (tsNormal, tsAnimated);
  14.  
  15.   TAnimatedTrayIcon = class(TWindowedComponent)
  16.   private
  17.     { property variables }
  18.     FAboutInfo     : TAboutInfo;
  19.     FActive        : Boolean;
  20.     FIcon          : TIcon;
  21.     FIcons         : TAnimatedIcons;
  22.     FHint          : String;
  23.     FPopupMenu     : TPopupMenu;
  24.     FRepeatCount   : Integer;
  25.     FShowHint      : Boolean;
  26.     FStyle         : TTrayIconStyle;
  27.     { event variables }
  28.     FOnClick       : TNotifyEvent;
  29.     FOnDblClick    : TNotifyEvent;
  30.     FOnEndAnimation: TNotifyEvent;
  31.     FOnMouseDown   : TTIMouseEvent;
  32.     FOnMouseMove   : TTIMouseMove;
  33.     FOnMouseUp     : TTIMouseEvent;
  34.     { internal variables }
  35.     FVisAppStyle   : Integer;
  36.     FInvAppStyle   : Integer;
  37.     FCallBackMsg   : Word;
  38.     FPreventClick  : Boolean;
  39.     { Property setting routines }
  40.     procedure SetActive(Value: Boolean);
  41.     procedure SetAnimatedIcons(Value: TAnimatedIcons);
  42.     procedure SetHint(Value: String);
  43.     procedure SetIcon(Value: TIcon);
  44.     procedure SetPopupMenu(Value: TPopupMenu);
  45.     procedure SetRepeatCount(Value: Integer);
  46.     procedure SetShowHint(Value: Boolean);
  47.     procedure SetStyle(Value: TTrayIconStyle);
  48.   protected
  49.     { Internal routines }
  50.     procedure ShellNotifyIcon(Msg: DWord; Flags: UInt; Icon: TIcon);
  51.     procedure HandleTrayMessage(const Msg: Longint);
  52.     function  LoadWorldIcon: THandle;
  53.     procedure IconChange(Sender: TObject);
  54.     function  GetControlKeys(const Shift: TShiftState): TShiftState;
  55.     procedure NewFrame(Sender: TObject; Frame: Integer);
  56.     procedure AnimStopped(Sender: TObject);
  57.     function  GetActiveIcon: TIcon;
  58.     { event dispatch routines }
  59.     procedure DoClick;
  60.     procedure DoDblClick;
  61.     procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState);
  62.     procedure DoMouseMove;
  63.     procedure DoMouseUp(Button: TMouseButton);
  64.     { Overrides }
  65.     procedure WndProc(var Msg: TMessage); override;
  66.     procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  67.     procedure Loaded; override;
  68.   public
  69.     { Constructor / destructor overrides }
  70.     constructor Create(AOwner: TComponent); override;
  71.     destructor Destroy; override;
  72.     { Methods }
  73.     procedure HideAppIcon;
  74.     procedure ShowAppIcon;
  75.   published
  76.     { Properties }
  77.     property About      : TAboutInfo     read FAboutInfo;
  78.     property Active     : Boolean        read FActive      write SetActive   default False;
  79.     property Icon       : TIcon          read FIcon        write SetIcon;
  80.     property Animation  : TAnimatedIcons read FIcons       write SetAnimatedIcons;
  81.     property Hint       : String         read FHint        write SetHint;
  82.     property PopupMenu  : TPopupMenu     read FPopupMenu   write SetPopupMenu;
  83.     property RepeatCount: Integer        read FRepeatCount write SetRepeatCount default 0;
  84.     property ShowHint   : Boolean        read FShowHint    write SetShowHint default True;
  85.     property Style      : TTrayIconStyle read FStyle       write SetStyle    default tsNormal;
  86.     { Events }
  87.     property OnClick       : TNotifyEvent   read FOnClick        write FOnClick;
  88.     property OnDblClick    : TNotifyEvent   read FOnDblClick     write FOnDblClick;
  89.     property OnEndAnimation: TNotifyEvent   read FOnEndAnimation write FOnEndAnimation;
  90.     property OnMouseDown   : TTIMouseEvent  read FOnMouseDown    write FOnMouseDown;
  91.     property OnMouseMove   : TTIMouseMove   read FOnMouseMove    write FOnMouseMove;
  92.     property OnMouseUp     : TTIMouseEvent  read FOnMouseUp      write FOnMouseUp;
  93.   end;
  94.  
  95. {$R ANITRAY.RES}
  96.  
  97. implementation
  98.  
  99. { TAnimatedTrayIcon }
  100. constructor TAnimatedTrayIcon.Create(AOwner: TComponent);
  101. begin
  102.   inherited Create(AOwner);
  103.   FCallbackMsg := RegisterWindowMessage('TAnimatedTrayIconCallBackMsg');
  104.   FIcon := TIcon.Create;
  105.   FIcon.Handle := LoadWorldIcon;
  106.   FIcon.OnChange := IconChange;
  107.   FIcons := TAnimatedIcons.Create(is16x16);
  108.   FIcons.OnNewFrame := NewFrame;
  109.   FIcons.OnStopped  := AnimStopped;
  110.   FShowHint := True;
  111.   FRepeatCount := 0;
  112.   FAboutInfo := TAboutInfo.Create;
  113.   with FAboutInfo do
  114.    begin
  115.      CopyrightDate := '1996/1997';
  116.      Company := 'SheAr software, Enschede, the Netherlands';
  117.      Description := 'Non-visible component that allows you to put animated icons in the Windows 95 or NT 4.0 system tray.';
  118.    end;
  119.   FVisAppStyle   := GetWindowLong(Application.Handle, GWL_EXSTYLE);
  120.   FInvAppStyle   := FVisAppStyle or WS_EX_TOOLWINDOW and (not WS_EX_APPWINDOW);
  121. end;
  122.  
  123. destructor TAnimatedTrayIcon.Destroy;
  124. begin
  125.   Active := False;
  126.   FIcon.Free;
  127.   FIcons.Free;
  128.   FAboutInfo.Free;
  129.   inherited Destroy;
  130. end;
  131.  
  132. procedure TAnimatedTrayIcon.Loaded;
  133. begin
  134.   inherited Loaded;
  135.   if Active then ShellNotifyIcon(NIM_ADD, NIF_MESSAGE or NIF_ICON or NIF_TIP, GetActiveIcon);
  136. end;
  137.  
  138. procedure TAnimatedTrayIcon.HandleTrayMessage(const Msg: Longint);
  139. var
  140.   Point: TPoint;
  141. begin
  142.   case Msg of
  143.     WM_LBUTTONDOWN  : begin
  144.                         FPreventClick := False;
  145.                         DoMouseDown(mbLeft, []);
  146.                       end;
  147.     WM_MBUTTONDOWN  : DoMouseDown(mbMiddle, []);
  148.     WM_RBUTTONDOWN  : begin
  149.                         DoMouseDown(mbRight, []);
  150.                         if Assigned(PopupMenu) then
  151.                          begin
  152.                            if Screen.ActiveForm<>nil then
  153.                             SetForeGroundWindow(Screen.ActiveForm.Handle)
  154.                            else
  155.                             SetForeGroundWindow(TForm(Owner).Handle);
  156.                            GetCursorPos(Point);
  157.                            PopupMenu.Popup(Point.X, Point.Y);
  158.                            PostMessage((Owner As TForm).Handle, WM_USER, 0, 0);
  159.                          end;
  160.                       end;
  161.     WM_LBUTTONUP    : begin
  162.                         if not FPreventClick then DoClick;
  163.                         DoMouseUp(mbLeft);
  164.                       end;
  165.     WM_RBUTTONUP    : DoMouseUp(mbRight);
  166.     WM_MBUTTONUP    : DoMouseUp(mbMiddle);
  167.     WM_LBUTTONDBLCLK: begin
  168.                         FPreventClick := True;
  169.                         DoDblClick;
  170.                         DoMouseDown(mbLeft, [ssDouble]);
  171.                       end;
  172.     WM_RBUTTONDBLCLK: DoMouseDown(mbRight, [ssDouble]);
  173.     WM_MBUTTONDBLCLK: DoMouseDown(mbMiddle, [ssDouble]);
  174.     WM_MOUSEMOVE    : DoMouseMove;
  175.   end;
  176. end;
  177.  
  178. procedure TAnimatedTrayIcon.WndProc(var Msg: TMessage);
  179. begin
  180.   with Msg do
  181.    if (Msg=FCallBackMsg) and (wParam=0) then
  182.     HandleTrayMessage(lParam)
  183.    else
  184.     inherited;
  185. end;
  186.  
  187. procedure TAnimatedTrayIcon.Notification(AComponent: TComponent; AOperation: TOperation);
  188. begin
  189.   inherited Notification(AComponent, AOperation);
  190.   if (AComponent = PopupMenu) and (AOperation = opRemove) then PopupMenu := nil;
  191. end;
  192.  
  193. { Public methods }
  194. procedure TAnimatedTrayIcon.HideAppIcon;
  195. begin
  196. á SetWindowLong(Application.Handle, GWL_EXSTYLE, FInvAppStyle);
  197. end;
  198.  
  199. procedure TAnimatedTrayIcon.ShowAppIcon;
  200. begin
  201.   SetWindowLong(Application.Handle, GWL_EXSTYLE, FVisAppStyle);
  202. end;
  203.  
  204. { Property get/set routines }
  205. procedure TAnimatedTrayIcon.SetActive(Value: Boolean);
  206. const
  207.   Values: array[Boolean] of DWord = (NIM_DELETE, NIM_ADD);
  208. begin
  209.   if FActive <> Value then
  210.    begin
  211.      FActive := Value;
  212.      ShellNotifyIcon(Values[Active], NIF_MESSAGE or NIF_ICON or NIF_TIP, GetActiveIcon);
  213.    end;
  214. end;
  215.  
  216. procedure TAnimatedTrayIcon.SetHint(Value : String);
  217. begin
  218.   if FHint <> Value then
  219.    begin
  220.      FHint := Value;
  221.      if Active then ShellNotifyIcon(NIM_MODIFY, NIF_TIP, FIcon);
  222.    end;
  223. end;
  224.  
  225. procedure TAnimatedTrayIcon.SetIcon(Value: TIcon);
  226. begin
  227.   FIcon.Assign(Value);
  228.   if FIcon.Empty then FIcon.Handle := LoadWorldIcon;
  229.   if Active and (FStyle=tsNormal) then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, FIcon);
  230. end;
  231.  
  232. procedure TAnimatedTrayIcon.SetShowHint(Value: Boolean);
  233. begin
  234.   if FShowHint<>Value then
  235.    begin
  236.      FShowHint := Value;
  237.      if Active then ShellNotifyIcon(NIM_MODIFY, NIF_TIP, FIcon);
  238.    end;
  239. end;
  240.  
  241. procedure TAnimatedTrayIcon.SetStyle(Value: TTrayIconStyle);
  242. begin
  243.   if FStyle<>Value then
  244.    begin
  245.      FStyle := Value;
  246.      if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
  247.    end;
  248. end;
  249.  
  250. procedure TAnimatedTrayIcon.SetAnimatedIcons(Value: TAnimatedIcons);
  251. begin
  252.   FIcons.Assign(Value);
  253. end;
  254.  
  255. procedure TAnimatedTrayIcon.SetPopupMenu(Value: TPopupMenu);
  256. begin
  257.   FPopupMenu := Value;
  258.   if Value <> nil then Value.FreeNotification(Self);
  259. end;
  260.  
  261. procedure TAnimatedTrayIcon.SetRepeatCount(Value: Integer);
  262. begin
  263.   if (Value>=0) and (Value<>FRepeatCount) then
  264.    begin
  265.      FRepeatCount := Value;
  266.      if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
  267.    end;
  268. end;
  269.  
  270. { Internal protected methods }
  271. procedure TAnimatedTrayIcon.IconChange(Sender: TObject);
  272. begin
  273.   if Active then ShellNotifyIcon(NIM_MODIFY, NIF_ICON, GetActiveIcon);
  274. end;
  275.  
  276. procedure TAnimatedTrayIcon.AnimStopped(Sender: TObject);
  277. begin
  278.   if (RepeatCount<>0) and Assigned(FOnEndAnimation) then
  279.    FOnEndAnimation(Self);
  280. end;
  281.  
  282. procedure TAnimatedTrayIcon.NewFrame(Sender: TObject; Frame: Integer);
  283. begin
  284.   ShellNotifyIcon(NIM_MODIFY, NIF_ICON, FIcons[Frame]);
  285. end;
  286.  
  287. function TAnimatedTrayIcon.LoadWorldIcon: THandle;
  288. begin
  289.   Result := LoadImage(hInstance, 'TRAYICON', IMAGE_ICON, 16, 16, 0) //LR_LOADREALSIZE);
  290. end;
  291.  
  292. function TAnimatedTrayIcon.GetActiveIcon: TIcon;
  293. begin
  294.   if (FStyle=tsAnimated) and (FIcons.Count>0) then
  295.    begin
  296.      if Active and not (csDesigning in ComponentState) then FIcons.Play(FRepeatCount);
  297.      Result := FIcons[0];
  298.    end
  299.   else
  300.    begin
  301.      if FIcons.Playing then FIcons.Stop;
  302.      Result := FIcon;
  303.    end;
  304. end;
  305.  
  306. procedure TAnimatedTrayIcon.ShellNotifyIcon(Msg: DWord; Flags: UInt; Icon: TIcon);
  307. var
  308.   NotifyData  : TNotifyIconData;
  309. begin
  310.   if (csDesigning in ComponentState) or (csLoading in ComponentState) then Exit;
  311.   with NotifyData do begin
  312.     cbSize := SizeOf(TNotifyIconData);
  313.     if ShowHint then
  314.      StrPLCopy(szTip, PChar(Hint), SizeOf(szTip))
  315.     else
  316.      szTip[0] := #0;
  317.     uFlags := Flags;
  318.     uID := 0;
  319.     Wnd := Handle;
  320.     uCallbackMessage := FCallBackMsg;
  321.     hIcon  := Icon.Handle;
  322.   end;
  323.   Shell_NotifyIcon(Msg, @NotifyData);
  324. end;
  325.  
  326. function TAnimatedTrayIcon.GetControlKeys(const Shift: TShiftState): TShiftState;
  327. begin
  328.   Result := Shift;
  329.   if GetAsyncKeyState(VK_CONTROL)<0 then Include(Result, ssCtrl);
  330.   if GetAsyncKeyState(VK_MENU)<0    then Include(Result, ssAlt);
  331.   if GetAsyncKeyState(VK_SHIFT)<0   then Include(Result, ssShift);
  332. end;
  333.  
  334. { Event dispatch routines }
  335. procedure TAnimatedTrayIcon.DoClick;
  336. begin
  337.   if Assigned(FOnClick) then FOnClick(Self);
  338. end;
  339.  
  340. procedure TAnimatedTrayIcon.DoDblClick;
  341. begin
  342.   if Assigned(FOnDblClick) then FOnDblClick(Self);
  343. end;
  344.  
  345. procedure TAnimatedTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState);
  346. begin
  347.   if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, GetControlKeys(Shift));
  348. end;
  349.  
  350. procedure TAnimatedTrayIcon.DoMouseMove;
  351. begin
  352.   if Assigned(FOnMouseMove) then FOnMouseMove(Self);
  353. end;
  354.  
  355. procedure TAnimatedTrayIcon.DoMouseUp(Button: TMouseButton);
  356. begin
  357.   if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, GetControlKeys([]));
  358. end;
  359.  
  360. end.
  361.