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