jvtrayicon.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvTrayIcon.PAS, released on 2001-02-28.

The Initial Developer of the Original Code is S閎astien Buysse [sbuysse att buypin dott com]
Portions created by S閎astien Buysse are Copyright (C) 2001 S閎astien Buysse.
All Rights Reserved.

Contributor(s):
  Michael Beck [mbeck att bigfoot dott com].
  Feng Mingyu(Winston Feng), [winstonf att tom dott com]
  Hans-Eric Gr鰊lund
  Vlad S

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

History:
  2004-03-23
     Added code to hide balloon correctly under W2k, as suggested by VladS
  2004-02-29
     VladS separate click and dblclick
  2003-09-28 by Winston Feng
    Add WM_SESSIONEND message handler, TaskbarRestart message handler to:
      Clean the trayicon when session ends.
      Restore the trayicon when session restart.
    Remove the old unsuccessful DoCheckCrash method.

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvTrayIcon.pas,v 1.39 2005/03/09 14:57:32 marquardt Exp $

unit JvTrayIcon;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls,
  Menus, ShellAPI, ImgList,
  {$IFDEF COMPILER6_UP}
  DateUtils,
  {$ENDIF COMPILER6_UP}
  JvConsts, JvTypes, JvComponent;

type
  TBalloonType = (btNone, btError, btInfo, btWarning);

  TNotifyIconDataXP = record
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
    szTip: array [0..127] of AnsiChar; // 0..64 for pre 5.0 shell versions
    dwState: DWORD;
    dwStateMask: DWORD;
    szInfo: array [0..255] of AnsiChar;
    uTimeOut: DWORD;
    szInfoTitle: array [0..63] of AnsiChar;
    dwInfoFlags: DWORD;
  end;

  TAnimateEvent = procedure(Sender: TObject; const ImageIndex: Integer) of object;

  { (rb) Change tvVisibleTaskBar to tvStartHidden or something; tvVisibleTaskBar
         is mainly used to indicate whether the application should start hidden
         with a trayicon; Functionality of tvVisibleTaskBar is available at
         run-time by using ShowApplication/HideApplication, at design-time it has
         no use, except to indicate whether the application should start hidden.
         Did not do the change because it changes the functionality of
         the trayicon, and could not come up with a backwards compatible way
         right-away }
  TTrayVisibility = (tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide, tvAutoHideIcon, tvVisibleDesign,
    tvRestoreClick, tvRestoreDbClick, tvMinimizeClick, tvMinimizeDbClick);
  TTrayVisibilities = set of TTrayVisibility;

  TJvTrayIconState = (tisTrayIconVisible, tisAnimating, tisHooked, tisHintChanged,
    tisWaitingForDoubleClick, tisAppHiddenButNotMinimized, tisClicked);
  TJvTrayIconStates = set of TJvTrayIconState;

  TJvTrayIcon = class(TJvComponent)
  private
    FTaskbarRestartMsg: Cardinal;
    FCurrentIcon: TIcon;
    FState: TJvTrayIconStates;
    FStreamedActive: Boolean;

    function GetApplicationVisible: Boolean;
    procedure SetApplicationVisible(const Value: Boolean);
  protected
    FActive: Boolean;
    FIcon: TIcon;
    FIconData: TNotifyIconDataXP;
    FHandle: THandle;
    FHint: string;
    FPopupMenu: TPopupMenu;
    FOnClick: TMouseEvent;
    FOnDblClick: TMouseEvent;

    // Under Windows 2000, in order to hide a balloon hint, BalloonHint must be
    // called with empty strings as many times it was called with real messages.
    // So we keep a counter of the number of times ballon hint was called to
    // track this and be sure to call a the right number of times when trying
    // to hide the balloon
    FBalloonCount: Integer;

    { Vlad S}
    {
    distinguish single-click and a double-click
    Create a timer which is started on the first click, set the timeout value to
    something a bit longer than the double-click, then connect the timeout() signal
    to a slot of your own. When a double click event is received you simply stop
    the timer. If the custom slot is visited you know that a single click was
    done.
    }
    FClickedButton: TMouseButton;
    FClickedShift: TShiftState;
    FClickedX: Integer;
    FClickedY: Integer;
    { Vlad S end.}

    FOnMouseMove: TMouseMoveEvent;
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    FOnContextPopup: TContextPopupEvent;
    FAnimated: Boolean;
    FDelay: Cardinal;
    FIcons: TCustomImageList;
    FIconIndex: Integer;
    FDropDownMenu: TPopupMenu;
    FTask: Boolean;
    FOnBalloonHide: TNotifyEvent;
    FOnBalloonShow: TNotifyEvent;
    FOnBalloonClick: TNotifyEvent;
    FTime: TDateTime;
    FTimeDelay: Integer;
    FOnAnimate: TAnimateEvent;
    FVisibility: TTrayVisibilities;
    FSnap: Boolean;
    function GetSystemMinimumBalloonDelay: Cardinal;
    procedure DoAnimation;
    procedure DoCloseBalloon;
    procedure DoTimerDblClick; { Vlad S}
    procedure IconChanged(Sender: TObject);
    procedure SetActive(Value: Boolean);
    procedure SetAnimated(const Value: Boolean);
    procedure SetDelay(const Value: Cardinal);
    procedure SetHint(Value: string);
    procedure SetIcon(Value: TIcon);
    procedure SetIconIndex(const Value: Integer);
    procedure SetIcons(const Value: TCustomImageList);
    procedure SetTask(const Value: Boolean);
    procedure SetVisibility(const Value: TTrayVisibilities);
    procedure StopTimer(ID: Integer);
    procedure Hook;
    procedure Unhook;
    procedure WndProc(var Mesg: TMessage);
    procedure DoContextPopup(X, Y: Integer);
    procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure DoMouseMove(Shift: TShiftState; X, Y: Integer);
    procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure DoDoubleClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure DoClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    function ApplicationHook(var Msg: TMessage): Boolean;
    function NotifyIcon(uFlags: UINT; dwMessage: DWORD): Boolean;
    procedure SetCurrentIcon(Value: TIcon); //HEG: New
    procedure IconPropertyChanged; //HEG: New
    procedure Loaded; override; //HEG: New

    procedure InitIconData;

    procedure ShowTrayIcon;
    procedure HideTrayIcon;

    procedure StartAnimation;
    procedure EndAnimation;

    property ApplicationVisible: Boolean read GetApplicationVisible write SetApplicationVisible;
    property VisibleInTaskList: Boolean read FTask write SetTask default True;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property CurrentIcon: TIcon read FCurrentIcon write SetCurrentIcon;
    procedure HideApplication;
    procedure ShowApplication;
    procedure BalloonHint(Title, Value: string; BalloonType:
      TBalloonType = btNone; ADelay: Cardinal = 5000; CancelPrevious: Boolean = False);
    function AcceptBalloons: Boolean;
    procedure HideBalloon;
  published
    property Active: Boolean read FActive write SetActive default False;
    property Animated: Boolean read FAnimated write SetAnimated default False;
    property Icon: TIcon read FIcon write SetIcon;
    property IconIndex: Integer read FIconIndex write SetIconIndex;
    property Icons: TCustomImageList read FIcons write SetIcons;
    property Hint: string read FHint write SetHint;
    property DropDownMenu: TPopupMenu read FDropDownMenu write FDropDownMenu;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property Delay: Cardinal read FDelay write SetDelay default 100;
    property Snap: Boolean read FSnap write FSnap default False;
    property Visibility: TTrayVisibilities read FVisibility write SetVisibility
      default [tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide];
    property OnAnimate: TAnimateEvent read FOnAnimate write FOnAnimate;
    property OnClick: TMouseEvent read FOnClick write FOnClick;
    property OnDblClick: TMouseEvent read FOnDblClick write FOnDblClick;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnBalloonShow: TNotifyEvent read FOnBalloonShow write FOnBalloonShow;
    property OnBalloonHide: TNotifyEvent read FOnBalloonHide write FOnBalloonHide;
    property OnBalloonClick: TNotifyEvent read FOnBalloonClick write FOnBalloonClick;
    property OnContextPopup: TContextPopupEvent read FOnContextPopup write FOnContextPopup;
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvTrayIcon.pas,v $';
    Revision: '$Revision: 1.39 $';
    Date: '$Date: 2005/03/09 14:57:32 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  JvJCLUtils, JvJVCLUtils;

type
  TRegisterServiceProcess = function(dwProcessID, dwType: Integer): Integer; stdcall;

const
  AnimationTimer = 1;
  CloseBalloonTimer = 2;
  DblClickTimer = 3;

  // The hint size is 64 for pre IE 5.0 Shell32 versions, 128 for newer versions.
  cHintSize: array [Boolean] of Cardinal = (64 - 1, 128 - 1);  // -1 for trailing #0

  Shell32VersionIE5 = $00050000;

  WM_CALLBACKMESSAGE = WM_USER + 1;

  // WIN32_IE >= = $0500
  NIN_SELECT          = (WM_USER + 0);
  NINF_KEY            = $1;
  NIN_KEYSELECT       = (NIN_SELECT or NINF_KEY);

  // WIN32_IE >= = $0501
  NIN_BALLOONSHOW     = (WM_USER + 2);
  NIN_BALLOONHIDE     = (WM_USER + 3);
  NIN_BALLOONTIMEOUT  = (WM_USER + 4);
  NIN_BALLOONUSERCLICK = (WM_USER + 5);

  NIM_ADD         = $00000000;
  NIM_MODIFY      = $00000001;
  NIM_DELETE      = $00000002;
  // WIN32_IE >= = $0500
  NIM_SETFOCUS    = $00000003;
  NIM_SETVERSION  = $00000004;
  NOTIFYICON_VERSION = 3;

  NIF_MESSAGE     = $00000001;
  NIF_ICON        = $00000002;
  NIF_TIP         = $00000004;
  // WIN32_IE >= = $0500
  NIF_STATE       = $00000008;
  NIF_INFO        = $00000010;
  // WIN32_IE >= = $600
  NIF_GUID        = $00000020;

  // WIN32_IE >= = $0500
  NIS_HIDDEN              = $00000001;
  NIS_SHAREDICON          = $00000002;

  // says this is the source of a shared icon

  // Notify Icon Infotip flags
  NIIF_NONE       = $00000000;
  // icon flags are mutually exclusive
  // and take only the lowest 2 bits
  NIIF_INFO       = $00000001;
  NIIF_WARNING    = $00000002;
  NIIF_ERROR      = $00000003;
  NIIF_ICON_MASK  = $0000000F;
  // WIN32_IE >= = $0501
  NIIF_NOSOUND    = $00000010;

  Kernel32DLLName = 'kernel32.dll';
  RegisterServiceProcessName = 'RegisterServiceProcess';

var
  GKernel32Handle: THandle = 0;
  GTriedLoadKernel32Dll: Boolean = False;
  RegisterServiceProcess: TRegisterServiceProcess = nil;

{ We get the following messages while clicking:

  Shell version < 5.0                |  Shell version >= 5.0
                                     |
  Single click     Double click      |  Single click          Double click
                                     |
  WM_BUTTONDOWN    WM_BUTTONDOWN     |  WM_BUTTONDOWN         WM_BUTTONDOWN
  WM_BUTTONUP      WM_BUTTONUP       |  WM_BUTTONUP           WM_BUTTONUP
                   WM_BUTTONDBLCLK   |  WM_CONTEXTMENU (*)    WM_CONTEXTMENU (*)
                   WM_BUTTONUP       |                        WM_BUTTONDBLCLK
                                     |                        WM_BUTTONUP
                                     |                        WM_CONTEXTMENU (*)
  (*) if clicked with the right mouse button.

  o  We use the tisClicked flag to indicate that we received a WM_BUTTONDOWN;
     if we receive a WM_BUTTONUP we can then make a difference between button ups
     from double click and from single clicks. DoClick is thus not called twice
     for double clicks.
     (similar to csClicked flag in TControl.ControlState)
  o  Normal behaviour for window controls is to call both DoClick and DoDoubleClick
     when the user double clicks the control. For the tray icon we don't want that.
     We use the tisWaitingForDoubleClick flag to indicate that we received a
     WM_BUTTONDOWN and WM_BUTTONUP and thus want to call DoClick. But instead of
     calling DoClick we start a timer; if we receive a WM_BUTTONDBLCLK before the
     timer ends, the user double clicked the icon otherwise it was a single click.
  o  For Shell32.dll versions before 5.0 we call DoContextPopup in WM_BUTTONUP
     to simulate WM_CONTEXTMENU messages.

  Thus the result is:

  Shell version < 5.0                     |  Shell version >= 5.0
                                          |
  Single click         Double click       |  Single click         Double click
                                          |
  WM_BUTTONDOWN        WM_BUTTONDOWN      |  WM_BUTTONDOWN        WM_BUTTONDOWN
    OnMouseDown          OnMouseDown      |    OnMouseDown          OnMouseDown
  WM_BUTTONUP          WM_BUTTONUP        |  WM_BUTTONUP          WM_BUTTONUP
    Start Timer          Start Timer      |    Start Timer          Start Timer
    OnMouseUp            OnMouseUp        |    OnMouseUp            OnMouseUp
    OnContextPopup (*)   OnContextPopup (*)| WM_CONTEXTMENU (*)   WM_CONTEXTMENU (*)
  WM_TIMER             WM_BUTTONDBLCLK    |    OnContextPopup        OnContextPopup
    OnClick      (**)    Stop Timer       |  WM_TIMER             WM_BUTTONDBLCLK
                         OnDoubleClick    |    OnClick     (**)     Stop Timer
                       WM_BUTTONUP        |                         OnDoubleClick
                         OnMouseUp        |                       WM_BUTTONUP
                         OnContextPopup   |                         OnMouseUp
                                          |                       WM_CONTEXTMENU (*)
                                          |                         OnContextPopup

   (*) if clicked with the right mouse button.
  (**) OnClick comes after the OnMouseUp. Another design decision could
       be to also delay OnMouseUp.
}

{$IFDEF COMPILER5}
function SecondsBetween(const Now: TDateTime; const FTime: TDateTime): Integer;
begin
  Result := Trunc(86400 * (FTime - Now));
end;
{$ENDIF COMPILER5}

function IsApplicationMinimized: Boolean;
begin
  Result := IsIconic(Application.Handle);
end;

procedure UnloadKernel32Dll;
begin
  RegisterServiceProcess := nil;
  if GKernel32Handle > 0 then
    FreeLibrary(GKernel32Handle);
  GKernel32Handle := 0;
end;

procedure LoadKernel32Dll;
begin
  if not GTriedLoadKernel32Dll then
  begin
    GTriedLoadKernel32Dll := True;

    GKernel32Handle := Windows.LoadLibrary(Kernel32DLLName);
    if GKernel32Handle > 0 then
      RegisterServiceProcess := GetProcAddress(GKernel32Handle, RegisterServiceProcessName);
  end;
end;

//=== { TJvTrayIcon } ========================================================

constructor TJvTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FCurrentIcon := TIcon.Create;
  FSnap := False;
  FHandle := AllocateHWndEx(WndProc);

  FState := [];
  FVisibility := [tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide];
  FAnimated := False;
  FDelay := 100;
  FIconIndex := 0;
  FBalloonCount := 0;
  FActive := False;
  FTask := True;

  { (rb) todo: make global }
  FTaskbarRestartMsg := RegisterWindowMessage('TaskbarCreated');
end;