trayicon.pas

Delphi Try Icon is a Delphi component to make our application able run in system tray

{ -----------------------------------------------------
  TrayIcon.pas

  Copyright (c) 2005, Dede KUrniadi
  (http://www.teknisoft.web.id)

  TTrayIcon Component v1.1,
  used to create icon on a Windows task bar
  ----------------------------------------------------- }
unit TrayIcon;

interface

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

type
  TTrayIcon = class(TComponent)
  private
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    parentHwnd: HWND;
    FID: UINT;
    FTip: string;
    FIcon: TIcon;
    FPopupMenu: TPopupMenu;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseDown: TNotifyEvent;
    FOnMouseMove: TNotifyEvent;
    FOnMouseUp: TNotifyEvent;

    function DoTray (action: DWORD): boolean;
    procedure SetFIcon(const Value: TIcon);
    procedure SetFTip(const Value: string);
  protected
    procedure WndProc (var Msg: TMessage);
    procedure IconChanged (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;

    function Show: boolean;
    function Hide: boolean;
  published
    property Icon: TIcon read FIcon write SetFIcon;
    property Tip: string read FTip write SetFTip;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TNotifyEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseMove: TNotifyEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TNotifyEvent read FOnMouseUp write FOnMouseUp;
  end;

procedure Register;

implementation

type
  NOTIFYICONDATA  = record
    cbSize           : DWORD;
    hWnd             : HWND;
    uID              : UINT;
    uFlags           : UINT;
    uCallbackMessage : UINT;
    hIcon            : HICON;
    szTip            : array [0..63] of char;
  end;

const
  NIM_ADD            = $0;
  NIM_MODIFY         = $1;
  NIM_DELETE         = $2;

  NIF_MESSAGE        = $1;
  NIF_ICON           = $2;
  NIF_TIP            = $4;

function Shell_NotifyIcon (
  flag: DWORD; var data: NOTIFYICONDATA): BOOL; stdcall;
  external 'shell32.dll' name 'Shell_NotifyIcon';

{ TTrayIcon }

constructor TTrayIcon.Create(AOwner: TComponent);
var
  form: TForm;
  i: integer;
  counter: integer;
begin
  // Call parent's constructor
  inherited Create (AOwner);

  // Assign default value
  FID   := 0;
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FTip  := '';

  // Set the new window procedure
  if (Owner is TForm) then
  begin
    parentHwnd := (Owner as TForm).Handle;
    OldWndProc := TFarProc (GetWindowLong (parentHwnd, GWL_WNDPROC));
    NewWndProc := MakeObjectInstance (WndProc);
    SetWindowLong (parentHwnd, GWL_WNDPROC, Longint (NewWndProc));

    counter := 0;
    form := (Owner as TForm);
    for i := 0 to form.ComponentCount - 1 do
      if (form.Components[i] is TTrayIcon) then
        inc (counter);
    FID := counter;
  end
  else
  begin
    parentHwnd := 0;
    OldWndProc := nil;
    NewWndProc := nil;
  end;
end;

destructor TTrayIcon.Destroy;
begin
  // Hide icon
  DoTray (NIM_DELETE);

  // Destroy icon
  FIcon.Free;

  // Restore the old window procedure
  if (OldWndProc <> nil) then
    SetWindowLong (parentHwnd, GWL_WNDPROC, Longint (OldWndProc));
  if (NewWndProc <> nil) then
    FreeObjectInstance (NewWndProc);

  // Call the default destructor
  inherited Destroy;
end;

function TTrayIcon.DoTray(action: DWORD): boolean;
var
  tnd: NOTIFYICONDATA;
begin
  tnd.cbSize := sizeof (NOTIFYICONDATA);
  tnd.hWnd := parentHwnd;
  tnd.uID := FID;
  tnd.uFlags := NIF_ICON or NIF_MESSAGE;
  if (FIcon.Empty) then
    tnd.hIcon := LoadIcon (0, IDI_WINLOGO)
  else
    tnd.hIcon := FIcon.Handle;
  tnd.uCallbackMessage := WM_USER + FID;

  if (FTip <> '') then
  begin
    tnd.uFlags := tnd.uFlags or NIF_TIP;
    StrPCopy (@tnd.szTip,  FTip);
  end;

  Result := Shell_NotifyIcon (action, tnd);
end;

function TTrayIcon.Show: boolean;
begin
  Result := DoTray (NIM_ADD);
end;

function TTrayIcon.Hide: boolean;
begin
  Result := DoTray (NIM_DELETE);
end;

procedure TTrayIcon.SetFIcon(const Value: TIcon);
begin
  FIcon.Assign (Value);
  DoTray (NIM_MODIFY);
end;

procedure TTrayIcon.SetFTip(const Value: string);
begin
  FTip := Value;
  DoTray (NIM_MODIFY);
end;

procedure TTrayIcon.WndProc (var Msg: TMessage);
var
  point: TPoint;
begin
  // Message from icon
  if (Msg.Msg = WM_USER + FID) then
  begin
    case Msg.lParam of
      WM_LBUTTONDBLCLK,
      WM_MBUTTONDBLCLK,
      WM_RBUTTONDBLCLK:
        if Assigned (OnDblClick) then
          OnDblClick (Self);

      WM_LBUTTONDOWN,
      WM_MBUTTONDOWN,
      WM_RBUTTONDOWN:
      begin
        if (Msg.lParam = WM_RBUTTONDOWN) and Assigned (FPopupMenu) and
           (FPopupMenu.AutoPopup) then
        begin
          SetForegroundWindow (parentHwnd);
          Application.ProcessMessages;
          FPopupMenu.PopupComponent := (Owner as TForm);
          GetCursorPos (point);
          FPopupMenu.Popup (point.x, point.y);
          Application.ProcessMessages;
        end

        else if Assigned (OnMouseDown) then
          OnMouseDown (Self)

        else if Assigned (OnClick) then
          OnClick (Self);
      end;

      WM_MOUSEMOVE:
        if Assigned (OnMouseMove) then
          OnMouseMove (Self);

      WM_LBUTTONUP,
      WM_MBUTTONUP,
      WM_RBUTTONUP:
        if Assigned (OnMouseUp) then
          OnMouseUp (Self);

      else
      begin
        Msg.Result := 1;
        exit;
      end;
    end;
  end

  // Call the default window procedure
  else
    Msg.Result := CallWindowProc (OldWndProc, parentHWnd,
      Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TTrayIcon.IconChanged (Sender: TObject);
begin
  DoTray (NIM_MODIFY);
end;

procedure Register;
begin
  RegisterComponents('Teknisoft', [TTrayIcon]);
end;

end.