// Bugs
//
// * Cannot initialize it's showtaskbar state
//
// Add
//
// * Parameter check ... for various options

unit lplTrayIcon;

{$WARN SYMBOL_DEPRECATED OFF}

interface

uses
  Windows, Messages, ShellApi, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, Menus, ExtCtrls;

{ 
  This message is sent to the special, hidden window for shell 
  notification messages. Only derived classes might need to 
  know about it. 
} 

const 
  WM_CALLBACK_MESSAGE = WM_USER + 1; 

  NIF_INFO = $10;
  NIF_MESSAGE = 1;
  NIF_ICON = 2;
  NOTIFYICON_VERSION = 3;
  NIF_TIP = 4;
  NIM_SETVERSION = $00000004;
  NIM_SETFOCUS = $00000003;
  NIIF_INFO = $00000001;
  NIIF_WARNING = $00000002;
  NIIF_ERROR = $00000003;

  NIN_BALLOONSHOW = WM_USER + 2;
  NIN_BALLOONHIDE = WM_USER + 3;
  NIN_BALLOONTIMEOUT = WM_USER + 4;
  NIN_BALLOONUSERCLICK = WM_USER + 5;
  NIN_SELECT = WM_USER + 0; 
  NINF_KEY = $1; 
  NIN_KEYSELECT = NIN_SELECT or NINF_KEY; 
   
  {define the callback message}
  TRAY_CALLBACK = WM_USER + $7258;

type
 TDUMMYUNIONNAME    = record
    case Integer of
      0: (uTimeout: UINT);
      1: (uVersion: UINT);
  end;
  TBalloonType = (btInfo, btWarning, btError);
  TNewNotifyIconData = record
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
   //Version 5.0 is 128 chars, old ver is 64 chars
    szTip: array [0..127] of Char;
    dwState: DWORD; //Version 5.0
    dwStateMask: DWORD; //Version 5.0
    szInfo: array [0..255] of Char; //Version 5.0
    DUMMYUNIONNAME: TDUMMYUNIONNAME;
    szInfoTitle: array [0..63] of Char; //Version 5.0
    dwInfoFlags: DWORD;   //Version 5.0
  end;
  TlplTrayIcon = class(TComponent)
  private
//    fBalloonShowing: Boolean;
    fData: TnewNotifyIconData;
    fIcon: TIcon;
    fHint: string;
    fPopupMenu: TPopupMenu;
    fClicked: Boolean;
    fOnClick: TNotifyEvent;
    fOnDblClick: TNotifyEvent;
    fOnMinimize: TNotifyEvent;
    fOnMouseMove: TMouseMoveEvent;
    fOnMouseDown: TMouseEvent;
    fOnMouseUp: TMouseEvent;
    fOnRestore: TNotifyEvent;
    fOnBalloonHide: TNotifyEvent;
    fOnBalloonTimeOut: TNotifyEvent;
    fOnBalloonClick: TNotifyEvent;
    fOnBalloonShow: TNotifyEvent;
    fShowOnTaskbar: Boolean;
    fAnimTimer: TTimer;
    fAnimate: Boolean;
    fAnimDelay: Cardinal;
    fImageList: TImageList;
    fAnimIndex: Integer;
    fRetrayTimer: TTimer;
    fRetray: Boolean;
    fRetrayDelay: Cardinal;
    fActive: Boolean;
    fOnUnableToRemove: TNotifyEvent;
    fOnUnableToCreate: TNotifyEvent;
    procedure OnAnimateTimer(Sender: TObject);
    procedure OnRetrayTimer(Sender: TObject);
    procedure SetShowMeTaskbar(const Value: Boolean);
    procedure SetAnimate(const Value: Boolean);
    procedure SetReTray(const Value: Boolean);
    procedure SetAnimateDelay(const Value: Cardinal);
    procedure SetRetrayInterval(const Value: Cardinal);
    procedure SetActive(const Value: Boolean);
    function AddIcon: boolean;
    Function DeleteIcon: boolean;
  protected
    procedure SetHint(const Hint: string); virtual;
    procedure SetIcon(Icon: TIcon); virtual;
    procedure AppMinimize(Sender: TObject);
    procedure AppRestore(Sender: TObject);
    procedure DoMenu; virtual;
    procedure Click; virtual;
    procedure DblClick; virtual;
    procedure EndSession; virtual;
    procedure DoMouseMove(Shift: TShiftState; X, Y: Integer); virtual;
    procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      virtual;
    procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      virtual;
    procedure OnMessage(var Msg: TMessage); virtual;
    procedure Changed; virtual;
    property Data: TnewNotifyIconData read fData;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure Minimize; virtual;
    procedure Restore; virtual;
    procedure ShowBalloonTips(BalloonType: TBalloonType; Msg, Title: String);
    Procedure DoRetray; virtual;
    procedure MinimizeToTray;
    procedure RestoreForm;
  published
    property Active: Boolean read fActive write SetActive;
    property Animate: Boolean read fAnimate write SetAnimate;
    property AnimateDelay: Cardinal read fAnimDelay write SetAnimateDelay;
    property ImageList: TImageList read fImageList write fImageList;
    property Hint: string read fHint write SetHint;
    property Icon: TIcon read fIcon write SetIcon;
    property PopupMenu: TPopupMenu read fPopupMenu write fPopupMenu;
    property ReTray: Boolean read fRetray write SetReTray;
    property ReTrayInterval: Cardinal read fRetrayDelay write SetRetrayInterval;
    property ShowOnTaskBar: Boolean read fShowOnTaskbar write SetShowMeTaskbar;
    property OnClick: TNotifyEvent read fOnClick write fOnClick;
    property OnDblClick: TNotifyEvent read fOnDblClick write fOnDblClick;
    property OnMinimize: TNotifyEvent read fOnMinimize write fOnMinimize;
    property OnMouseMove: TMouseMoveEvent read fOnMouseMove write fOnMouseMove;
    property OnMouseDown: TMouseEvent read fOnMouseDown write fOnMouseDown;
    property OnMouseUp: TMouseEvent read fOnMouseUp write fOnMouseUp;
    property OnRestore: TNotifyEvent read fOnRestore write fOnRestore;
    Property OnBalloonShow: TNotifyEvent read fOnBalloonShow write fOnBalloonShow;
    Property OnBalloonHide: TNotifyEvent read fOnBalloonHide write fOnBalloonHide;
    Property OnBalloonTimeout: TNotifyEvent read fOnBalloonTimeOut write fOnBalloonTimeOut;
    Property OnBalloonClick: TNotifyEvent read fOnBalloonClick write fOnBalloonClick;
    Property OnUnableToCreateIcon: TNotifyEvent read fOnUnableToCreate write fOnUnableToCreate;
    Property OnUnableToRemoveIcon: TNotifyEvent read fOnUnableToRemove write fOnUnableToRemove;
  end;
  PNewNotifyIconData = ^TNewNotifyIconData;

procedure Register;

implementation

constructor TlplTrayIcon.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  fIcon := TIcon.Create;
  fIcon.Assign(Application.Icon);
  if not (csDesigning in ComponentState) then
  begin
    FillChar(fData, SizeOf(fData), 0);
    fData.cbSize := SizeOf(fData);
    fData.Wnd  := AllocateHwnd(OnMessage); // handle to get notification message
    fData.hIcon  := Icon.Handle; // icon to display
    StrPLCopy(fData.szTip, Application.Title, SizeOf(fData.szTip) - 1);
    fData.uFlags := Nif_Icon or Nif_Message;
    if Application.Title <> '' then
      fData.uFlags := fData.uFlags or Nif_Tip;
    fData.uCallbackMessage := WM_CALLBACK_MESSAGE;
      {
        Replace the application's minimize and restore handlers with
        special ones for the tray. The TrayIcon component has its own
        OnMinimize and OnRestore events that the user can set.
      }
    Application.OnMinimize := AppMinimize;
    Application.OnRestore  := AppRestore;
    fShowOnTaskBar := True;
    fAnimTimer := TTimer.Create(self);
    fAnimTimer.Enabled := False;
    fAnimTimer.Interval := fAnimDelay;
    fAnimtimer.OnTimer := Self.OnAnimateTimer;
    Self.fAnimIndex := 0;
    fRetrayTimer := TTimer.Create(self);
    fRetrayTimer.Enabled := False;
    fRetrayTimer.OnTimer := Self.OnRetrayTimer;
  end;
end;

{ Remove the icon from the system tray.}
destructor TlplTrayIcon.Destroy;
begin
  fAnimTimer.Free;
  fRetrayTimer.Free;
  fIcon.Free;
  if not (csDesigning in ComponentState) then
    Shell_NotifyIcon(Nim_Delete, @fData);
  inherited Destroy;
end;

{ Whenever any information changes, update the system tray. } 
procedure TlplTrayIcon.Changed;
begin 
  if not (csDesigning in ComponentState) then
    Shell_NotifyIcon(NIM_MODIFY, @fData);
end; 

{ When the Application is minimized, minimize to the system tray.} 
procedure TlplTrayIcon.AppMinimize(Sender: TObject); 
begin
  Minimize;
end;

{ When restoring from the system tray, restore the application. }
procedure TlplTrayIcon.AppRestore(Sender: TObject);
begin
  Restore;
end;

{
  Message handler for the hidden shell notification window.
  Most messages use Wm_Callback_Message as the Msg ID, with
  WParam as the ID of the shell notify icon data. LParam is
  a message ID for the actual message, e.g., Wm_MouseMove.
  Another important message is Wm_EndSession, telling the
  shell notify icon to delete itself, so Windows can shut down.

  Send the usual Delphi events for the mouse messages. Also
  interpolate the OnClick event when the user clicks the
  left button, and popup the menu, if there is one, for
  right click events.
}

procedure TlplTrayIcon.OnMessage(var Msg: TMessage);
  { Return the state of the shift keys. }
  function ShiftState: TShiftState;
  begin
    Result := [];
    if GetKeyState(VK_SHIFT) < 0 then
      Include(Result, ssShift);
    if GetKeyState(VK_CONTROL) < 0 then
      Include(Result, ssCtrl);
    if GetKeyState(VK_MENU) < 0 then
      Include(Result, ssAlt);
  end;
var
  Pt: TPoint;
  Shift: TShiftState;
begin
  case Msg.Msg of
    Wm_QueryEndSession:
      Msg.Result := 1;
    Wm_EndSession:
      if TWmEndSession(Msg).EndSession then
        EndSession;
    Wm_Callback_Message:
      case Msg.lParam of
        WM_MOUSEMOVE:
          begin
            Shift := ShiftState;
            GetCursorPos(Pt);
            DoMouseMove(Shift, Pt.X, Pt.Y);
          end;
        WM_LBUTTONDOWN:
          begin
            Shift := ShiftState + [ssLeft];
            GetCursorPos(Pt);
            DoMouseDown(mbLeft, Shift, Pt.X, Pt.Y);
            fClicked := True;
          end;
        WM_LBUTTONUP:
          begin
            Shift := ShiftState + [ssLeft];
            GetCursorPos(Pt);
            if fClicked then
            begin
              fClicked := False;
              Click;
            end;
            DoMouseUp(mbLeft, Shift, Pt.X, Pt.Y);
          end;
        WM_LBUTTONDBLCLK:
          DblClick;
        WM_RBUTTONDOWN:
          begin
            Shift := ShiftState + [ssRight];
            GetCursorPos(Pt);
            DoMouseDown(mbRight, Shift, Pt.X, Pt.Y);
            DoMenu;
          end;
        WM_RBUTTONUP:
          begin
            Shift := ShiftState + [ssRight];
            GetCursorPos(Pt);
            DoMouseUp(mbRight, Shift, Pt.X, Pt.Y);
          end;
        WM_RBUTTONDBLCLK:
          DblClick;
        WM_MBUTTONDOWN:
          begin
            Shift := ShiftState + [ssMiddle];
            GetCursorPos(Pt);
            DoMouseDown(mbMiddle, Shift, Pt.X, Pt.Y);
          end;
        WM_MBUTTONUP:
          begin
            Shift := ShiftState + [ssMiddle];
            GetCursorPos(Pt);
            DoMouseUp(mbMiddle, Shift, Pt.X, Pt.Y);
          end;
        WM_MBUTTONDBLCLK:
          begin
            DblClick;
          end;
        NIN_BALLOONSHOW:
          begin
            If assigned(fOnBalloonShow) then fOnBalloonShow(Self);
          end;
        NIN_BALLOONHIDE:
          begin
            If Assigned(fOnBalloonHide) then fOnBalloonHide(Self);
            fData.uFlags := Nif_Icon or Nif_Message;
          end;
        NIN_BALLOONTIMEOUT:
          begin
            If Assigned(fOnBalloonTimeOut) then fOnBalloonTimeOut(Self);
            fData.uFlags := Nif_Icon or Nif_Message;
          end;
        NIN_BALLOONUSERCLICK:
          begin
            If Assigned(fOnBalloonClick) Then fOnBalloonClick(Self);
            fData.uFlags := Nif_Icon or Nif_Message;
          end;
      end;
  end;
end;

{ Set a new hint, which is the tool tip for the shell icon. }
procedure TlplTrayIcon.SetHint(const Hint: string);
begin
  if fHint <> Hint then
  begin
    fHint := Hint;
    StrPLCopy(fData.szTip, Hint, SizeOf(fData.szTip) - 1);
    if Hint <> '' then
      fData.uFlags := fData.uFlags or Nif_Tip
    else
      fData.uFlags := fData.uFlags and not Nif_Tip;
    Changed;
  end;
end;

{ Set a new icon. Update the system tray. }
procedure TlplTrayIcon.SetIcon(Icon: TIcon);
begin
  if fIcon <> Icon then
  begin
    fIcon.Assign(Icon);
    fData.hIcon := Icon.Handle;
    Changed;
  end;
end;

{
  When the user right clicks the icon, call DoMenu.
  If there is a popup menu, and if the window is minimized,
  then popup the menu.
}

procedure TlplTrayIcon.DoMenu;
var
  Pt: TPoint;
begin
  if (fPopupMenu <> nil) Then // and not IsWindowVisible(Application.Handle) then
  begin
    GetCursorPos(Pt);
    fPopupMenu.Popup(Pt.X, Pt.Y);
  end;
end;

procedure TlplTrayIcon.Click;
begin
  if Assigned(fOnClick) then
    fOnClick(Self);
end;

procedure TlplTrayIcon.DblClick;
begin
  if Assigned(fOnDblClick) then
    fOnDblClick(Self);
end;

procedure TlplTrayIcon.DoMouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(fOnMouseMove) then
    fOnMouseMove(Self, Shift, X, Y);
end;

procedure TlplTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(fOnMouseDown) then
    fOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TlplTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
begin
  if Assigned(fOnMouseUp) then 
    fOnMouseUp(Self, Button, Shift, X, Y); 
end; 

{ 
  When the application minimizes, hide it, so only the icon 
  in the system tray is visible. 
} 
procedure TlplTrayIcon.Minimize; 
begin
  ShowWindow(Application.Handle, SW_HIDE); 
  if Assigned(fOnMinimize) then
    fOnMinimize(Self);
end; 

{ 
  Restore the application by making its window visible again, 
  which is a little weird since its window is invisible, having 
  no height or width, but that's what determines whether the button 
  appears on the taskbar. 
}

procedure TlplTrayIcon.Restore;
begin
  ShowWindow(Application.Handle, SW_RESTORE);
  if Assigned(fOnRestore) then
    fOnRestore(Self);
end;

{ Allow Windows to exit by deleting the shell notify icon. }
procedure TlplTrayIcon.EndSession;
begin
  Shell_NotifyIcon(Nim_Delete, @fData);
end;

procedure TlplTrayIcon.ShowBalloonTips(BalloonType: TBalloonType; Msg, Title: String);
var
  TipInfo, TipTitle: string;
begin
  fData.cbSize := SizeOf(fData);
  fData.uFlags := NIF_INFO;
  TipInfo := Msg;
  strPLCopy(fData.szInfo, TipInfo, SizeOf(fData.szInfo) - 1);
  fData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
  fData.DUMMYUNIONNAME.uTimeout := 3000;
  TipTitle := title;
  strPLCopy(fData.szInfoTitle, TipTitle, SizeOf(fData.szInfoTitle) - 1);
  Case Balloontype of
   btInfo: fData.dwInfoFlags := NIIF_INFO;
   btWarning: fData.dwInfoFlags := NIIF_WARNING;
   btError: fData.dwInfoFlags := NIIF_ERROR;
  End;
  Shell_NotifyIcon(NIM_MODIFY, @fData);
  {in my testing, the following code has no use}
end;

procedure Register;
begin
  RegisterComponents('LPL Tools', [TlplTrayIcon]);
end;

procedure TlplTrayIcon.SetShowMeTaskbar(const Value: Boolean);
begin
 If value <> fShowOnTaskBar Then begin
  If (csDesigning in componentstate) Then begin
  End
   else
  Begin
   If value Then Begin
    Showwindow(application.Handle, SW_SHOW);
   End
    else
   Begin
    Showwindow(Application.Handle, SW_HIDE);
   End;
  End;
  fShowOnTaskbar := Value;
 End;
end;

procedure TlplTrayIcon.SetAnimate(const Value: Boolean);
begin
  fAnimate := Value;
  If fAnimate Then begin
   If not assigned(fImagelist) Then Begin
    fAnimate := False;
    exit;
   End;
   fAnimtimer.Interval := fAnimDelay;
   fAnimTimer.Enabled := fAnimate;
  End;
end;

procedure TlplTrayIcon.OnAnimateTimer(Sender: TObject);
Var
 Icon: TIcon;
begin
 If Assigned(fImagelist) then begin
  Icon := TIcon.Create;
  fImagelist.GetIcon(fAnimIndex, Icon);
  SetIcon(Icon);
  Icon.Free;
  Self.Changed;
  Inc(fAnimIndex);
  If fAnimIndex = fImageList.Count Then fAnimIndex := 0;
 End;
end;

procedure TlplTrayIcon.SetReTray(const Value: Boolean);
begin
  fRetray := Value;
  If assigned(fRetrayTimer) then fRetrayTimer.Enabled := fRetray;
end;

procedure TlplTrayIcon.DoRetray;
begin
 Shell_NotifyIcon(NIM_DELETE, @fData);
 Shell_NotifyIcon(NIM_ADD, @fData);
end;

procedure TlplTrayIcon.SetAnimateDelay(const Value: Cardinal);
begin
  fAnimDelay := Value;
  If assigned(fAnimTimer) Then fAnimTimer.Interval := Value;
end;

procedure TlplTrayIcon.SetRetrayInterval(const Value: Cardinal);
begin
  fRetrayDelay := Value;
  If Assigned(fRetrayTimer) Then fRetrayTimer.Interval := Value;
end;

procedure TlplTrayIcon.OnRetrayTimer(Sender: TObject);
begin
 DoRetray;
end;

procedure TlplTrayIcon.MinimizeToTray;
begin
 If Assigned(fOnMinimize) then fOnMinimize(Self);
 if not Active then
 begin
   if Application.MainForm = nil then
     Application.ShowMainForm := False
   else
     Application.MainForm.Visible := False;
   ShowWindow(Application.Handle, SW_HIDE);
   Active := True;
 end;
end;

procedure TlplTrayIcon.SetActive(const Value: Boolean);
begin
 If (csDesigning in Componentstate) then exit;
 If fActive <> Value Then begin
  fActive := Value;
  If fActive Then begin
   If Not AddIcon Then
    If Assigned(fOnUnableToCreate) Then fOnUnableToCreate(Self);
  end
   else
  Begin
   If Not DeleteIcon Then
    If Assigned(fOnUnableToRemove) Then fOnUnableToRemove(Self);
  End;
 End;
end;

function TlplTrayIcon.AddIcon: boolean;
begin
 Result := Shell_NotifyIcon(NIM_ADD, @fData);
end;

function TlplTrayIcon.DeleteIcon: boolean;
begin
 Result := Shell_NotifyIcon(NIM_DELETE, @fData);
end;

procedure TlplTrayIcon.RestoreForm;
begin
 If Assigned(fOnRestore) Then fOnRestore(Self);
 if Active then
 begin
   ShowWindow(Application.Handle, SW_RESTORE);
   Application.MainForm.Visible := True;
   SetForeGroundWindow(Application.Handle);
   Active := False;
 end;
end;

end.
