How To Implement a Systray Icon (Revision 3)

unit systray_comp;
  { system tray icon component written by Glenn9999 of tek-tips.com }
interface

  {$R SYSTRAY_comp.DCR}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  shellapi, registry;

const
  // constants for systray icon control
  NIF_MESSAGE = 1;
  NIF_ICON = 2;
  NOTIFYICON_VERSION = 3;
  NIF_TIP = 4;
  NIM_SETFOCUS = $03;
  NIM_SETVERSION = $04;
  NIF_INFO = $10;

  // constants for systray balloon tip control
  NIIF_NONE = $00;    // no bt icon
  NIIF_INFO = $01;    // info icon
  NIIF_WARNING = $02; // warning icon
  NIIF_ERROR = $03;   // error icon
  NIIF_USER = $04;    // same icon as the system tray
  NIIF_NOSOUND = $10; // no sound to be played

  // events generated off of systray icon balloon tip.
  NIN_SELECT = WM_USER + 0;
  NIN_BALLOONSHOW = WM_USER + 2;
  NIN_BALLOONHIDE = WM_USER + 3;
  NIN_BALLOONTIMEOUT = WM_USER + 4;
  NIN_BALLOONUSERCLICK = WM_USER + 5;
  {NINF_KEY = $1;
  NIN_KEYSELECT = NIN_SELECT or NINF_KEY; }

  WM_ICONTRAY = WM_USER + $20;

type
  // the new systray icon structures.  Old ones are defined in shellapi
  // as TNotifyIconData.

  TDUMMYUNIONNAME = record
    case Integer of
      0: (uTimeout: UINT);
      1: (uVersion: UINT);
    end;

  TNotifyIconData2 = record
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
    szTip: array [0..127] of Char;
    dwState: DWORD;
    dwStateMask: DWORD;
    szInfo: array [0..255] of Char;
    DUMMYUNIONNAME: TDUMMYUNIONNAME;
    szInfoTitle: array [0..63] of Char;
    dwInfoFlags: DWORD;
  end;

  TBTipType = (btNone, btInfo, btWarning, btError, btUser);

  TSysTrayIcon = class(TComponent)
  private   { Private declarations }
    FTrayID: integer;
    FAppTitle: string;
    FIcon: TIcon;
    FTipInfo: string;
    FTipTitle: string;
    FTipTimeOut: integer;
    FTipType: TBTipType;
    FVisible: Boolean;
    FUseSound: Boolean;
    FTransparentColor: TColor;
    FHandle: HWnd;
    FTrayIconData: TNotifyIconData2;
    // notification events
    FOnMouseMove: TMouseMoveEvent;
    FOnLClick: TNotifyEvent;
    FOnRClick: TNotifyEvent;
    FOnMouseUp: TMouseEvent;
    FOnMouseDown: TMouseEvent;
    FOnLDblClick: TNotifyEvent;
    FOnRDblClick: TNotifyEvent;
    FOnBalloonShow: TNotifyEvent;
    FOnBalloonHide: TNotifyEvent;
    FOnBalloonTimeOut: TNotifyEvent;
    FOnBalloonClick: TNotifyEvent;
    procedure SetIcon(Value: TIcon);
    procedure SetVisible(Value: Boolean);
  protected { Protected declarations }
    procedure Loaded; override;
    procedure TrayMessage(var Message: TMessage); message WM_ICONTRAY;
  public    { Public declarations }
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    procedure addtray;
    procedure modifytray;
    procedure deletetray;
    procedure showballoontip;
     function BalloonTipsAllowed: boolean;
    procedure BitMapToIcon(myBitmap: TBitmap);
  published { Published declarations }
    property AppTitle: string read FAppTitle write FAppTitle;
    property Icon: TIcon read FIcon write SetIcon;
    property TrayID: integer read FTrayID write FTrayID default 15;
    property TipInfo: string read FTipInfo write FTipInfo;
    property TipTitle: string read FTipTitle write FTipTitle;
    property TipTimeOut: integer read FTipTimeOut write FTipTimeOut default 300;
    property TipType: TBTipType read FTipType write FTipType;
    property UseSound: Boolean read FUseSound write FUseSound;
    property TransparentColor: TColor read FTransparentColor write FTransparentColor;
    property Visible: Boolean read FVisible write Setvisible;
    property OnLClick: TNotifyEvent read FOnLClick write FOnLClick;
    property OnRClick: TNotifyEvent read FOnRClick write FOnRClick;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnLDblClick: TNotifyEvent read FOnLDblClick write FOnLDblClick;
    property OnRDblClick: TNotifyEvent read FOnRDblClick write FOnRDblClick;
    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;
  end;

procedure Register;
procedure hidetaskbar(winhandle: HWnd);
procedure showtaskbar(winhandle: HWnd);

implementation

Constructor TSysTrayIcon.Create(AOwner: TComponent);
  begin
    FIcon := TIcon.Create;
    FHandle := AllocateHWnd(TrayMessage);
    Inherited Create(AOwner);
  end;

Destructor TSysTrayIcon.Destroy;
  begin
    DeallocateHWnd(FHandle);
    DeleteTray;
    FIcon.Free;
    Inherited;
  end;

 function TSysTrayIcon.BalloonTipsAllowed: boolean;
   { determines if balloon tips are allowed }
    const
      HKEY_CURRENT_USER = $80000001;
      keyname = '\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced';
      strname = 'EnableBalloonTips';
    var
      workcheck: TRegistry;
      isinreg: boolean;
      balloontips: integer;
    begin
      isinreg := true;
      workcheck := TRegistry.Create;
      workcheck.rootkey := HKEY_CURRENT_USER;
      if workcheck.openkey(keyname, false) then
        begin
          try
            balloontips := workcheck.ReadInteger(strname);
            if balloontips = 0 then isinreg := false;
          except
            isinreg := true;
          end;
        end;
      workcheck.destroy;
      Result := isinreg;
    end;

procedure TSysTrayIcon.Loaded;
  { initializations of the control }
  const
    warning_message = 'Balloon tips are not configured for this system '
       + 'and will not work in the TSysTrayIcon component.' + #13#10
       + 'Please contact your administrator. For details see Microsoft KB #307729';
  begin
    inherited loaded;
    // enforce defaults
    if (csDesigning in ComponentState) then
      begin
        if BalloonTipsAllowed = false then
          ShowMessage(warning_message);
      end
    else
      begin
        if FIcon.Empty then FIcon.Assign(Application.Icon);
        if TipInfo = '' then
          TipInfo := 'You need to assign your own balloon tip message here.';
      end;
  end;

procedure TSysTrayIcon.SetIcon(Value: TIcon);
  begin
    FIcon.Assign(Value);
  end;

procedure TSysTrayIcon.SetVisible(Value: Boolean);
  begin
    FVisible := Value;
    if (csDesigning in ComponentState) then exit;
    FVisible := not FVisible;
    If Value then
      AddTray
    else
      DeleteTray;
  end;

procedure TSysTrayIcon.AddTray;
  begin
    if FVisible then exit;

    with FTrayIconData do
      begin
        cbSize := SizeOf(FTrayIconData);
        Wnd := FHandle;
        uID := Ftrayid;
        uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
        uCallbackMessage := WM_ICONTRAY;
        hIcon := FIcon.Handle;
        StrPCopy(szTip, Fapptitle);
      end;
    Shell_NotifyIcon(NIM_ADD, @FTrayIconData);
   //need to set version with this tray icon to fully support tool tips.
    Integer(FTrayIconData.DUMMYUNIONNAME) := 4;
    Shell_NotifyIcon(NIM_SETVERSION, @FTrayIconData);
    FVisible := true;
  end;

procedure TSysTrayIcon.ModifyTray;
  begin
    if not FVisible then exit;
    with FTrayIconData do
      begin
        cbSize := SizeOf(FTrayIconData);
        Wnd := FHandle;
        uID := Ftrayid;
        uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
        uCallbackMessage := WM_ICONTRAY;
        hIcon := FIcon.Handle;
        StrPCopy(szTip, Fapptitle);
      end;
    Shell_NotifyIcon(NIM_MODIFY, @FTrayIconData);
  end;

procedure TSysTrayIcon.DeleteTray;
  begin
    if not FVisible then exit;
    Shell_NotifyIcon(NIM_DELETE, @FTrayIconData);
    FVisible := False;
  end;

procedure TSysTrayIcon.ShowBalloonTip;
  var
    ni_value: integer;
  begin
    if not FVisible then exit;

    case FTipType of
      btNone: ni_value := NIIF_NONE;
      btInfo: ni_value := NIIF_INFO;
      btWarning: ni_value := NIIF_WARNING;
      btError: ni_value := NIIF_ERROR;
      btUser: ni_value := NIIF_USER;
    else
      ni_value := 0;
    end;
    if FUseSound = false then
      ni_value := ni_value + NIIF_NOSOUND;
    With FTrayIconData do
      begin
        cbSize := SizeOf(FTrayIconData);
        uFlags := NIF_INFO;
        strPLCopy(szInfo, FTipInfo, SizeOf(szInfo) - 1);
        DUMMYUNIONNAME.uTimeout := FTipTimeout;
        strPLCopy(szInfoTitle, FTipTitle, SizeOf(szInfoTitle) - 1);
        dwInfoFlags := ni_value;
      end;
    Shell_NotifyIcon(NIM_MODIFY, @FTrayIconData);
  end;

procedure TSysTrayIcon.BitMapToIcon(myBitmap: TBitmap);
var
  IconSizeX : integer;
  IconSizeY : integer;
  AndMask : TBitmap;
  oldcol : integer;
  ColorBMP : TBitmap;
  IconInfo : TIconInfo;
begin
  IconSizeX := myBitmap.Width;
  IconSizeY := myBitmap.Height;

  AndMask := TBitmap.Create;
  ColorBMP := TBitmap.Create;
  try
  // AndMask needs to be black everywhere the image is supposed to show.
  // if you want the BMP to show entirely as is, make this BMP to be all black
    AndMask.Width := IconSizeX;
    AndMask.Height := IconSizeY;
    oldcol := SetBkColor(myBitmap.Canvas.Handle, ColorToRGB(fTransparentColor));
    AndMask.Monochrome := true;
    AndMask.Canvas.CopyMode := cmSrcCopy;
    AndMask.Canvas.Draw(0, 0, myBitmap);
    SetBkColor(myBitmap.Canvas.Handle, oldcol);

  // ColorBMP is the full color image.  The transparent color must be replaced
  // with black in this image for the transparency to work.
    ColorBMP.Width := IconSizeX;
    ColorBMP.Height := IconSizeY;
    ColorBMP.PixelFormat := pf24bit;
    ColorBMP.Canvas.Brush.Color := clBlack;
    ColorBMP.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
    myBitmap.TransparentColor := fTransparentColor;
    myBitmap.Transparent := true;
    ColorBMP.Canvas.StretchDraw(Rect(0,0,IconSizeX,IconSizeY), myBitmap);

   {Create a icon}
    IconInfo.fIcon := false;
    IconInfo.xHotspot := 0;
    IconInfo.yHotspot := 0;
    IconInfo.hbmMask :=  AndMask.Handle;
    IconInfo.hbmColor := ColorBMP.Handle;
    Icon.Handle := CreateIconIndirect(IconInfo);
  finally
    AndMask.Free;
    ColorBMP.Free;
  end;
end;

procedure TSysTrayIcon.TrayMessage(var Message: TMessage);
  { driver routine, forms messages and dispatches them to the user of the
    component. }
  var
    P: TPoint;
  begin
    if Message.Msg = WM_ICONTRAY then
      begin
        GetCursorPos(p);
        case Message.lParam of
          WM_LBUTTONDOWN:
            begin
              if Assigned(FOnLClick) then OnLClick(Self);
              if Assigned(FOnMouseDown) then
                 OnMouseDown(Self, mbLeft, [ssShift], p.x, p.y);
            end;
          WM_LBUTTONUP:
            if Assigned(FOnMouseUp) then
              OnMouseUp(Self, mbLeft, [ssShift], p.x, p.y);
          WM_LBUTTONDBLCLK:
            if Assigned(FOnLDblClick) then OnLDblClick(Self);
          WM_RBUTTONDOWN:
            begin
              if Assigned(FOnRClick) then OnRClick(Self);
              if Assigned(FOnMouseDown) then
                OnMouseDown(Self, mbRight, [ssShift], p.x, p.y);
            end;
          WM_RBUTTONUP:
            if Assigned(FOnMouseUp) then
              OnMouseDown(Self, mbRight, [ssShift], p.x, p.y);
          WM_RBUTTONDBLCLK:
            if Assigned(FOnRDblClick) then OnRDblClick(Self);
          WM_MOUSEMOVE:
            If Assigned(FOnMouseMove) then
              OnMouseMove(Self, [ssShift], p.x, p.y);
        //  NIN_BALLOONSHOW - done when the b. tip is shown,
          NIN_BALLOONSHOW:
            if Assigned(FOnBalloonShow) then OnBalloonShow(Self);
        //  NIN_BALLOONHIDE - done when the b. tip disappears; like if the icon is
        //    deleted,
          NIN_BALLOONHIDE:
            if Assigned(FOnBalloonHide) then OnBalloonHide(Self);
        //  NIN_BALLOONTIMEOUT - done when the b.tip timeout occurs; the timeout
        //    doesn't start if the app the systray icon belongs to has focus - this
        //    will also occur upon clicking the [X],
          NIN_BALLOONTIMEOUT:
            if Assigned(FOnBalloonTimeout) then OnBalloonTimeout(Self);
        //  NIN_BALLOONUSERCLICK - done if the b.tip itself is clicked.
          NIN_BALLOONUSERCLICK:
            if Assigned(FOnBalloonClick) then OnBalloonClick(Self);
        end;
      end
    else
      Message.Result := DefWindowProc(Fhandle, Message.Msg,
                                  Message.WParam, Message.LParam);
  end;

procedure hidetaskbar(winhandle: HWnd);
  // this all hides the app from the task bar
  var
    GWL: Integer;
  begin
    ShowWindow(winhandle, SW_HIDE);
    GWL := getWindowLong(Winhandle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW;
    SetWindowLong(winhandle, GWL_EXSTYLE, GWL);
    ShowWindow(WinHandle, SW_SHOW);
  end;

procedure showtaskbar(winhandle: HWnd);
  // this shows the app on the task bar
  var
    GWL: Integer;
  begin
    ShowWindow(winhandle, SW_HIDE);
    GWL := not WS_EX_TOOLWINDOW and getWindowLong(Winhandle, GWL_EXSTYLE);
    SetWindowLong(winhandle, GWL_EXSTYLE, GWL);
    ShowWindow(WinHandle, SW_SHOW);
  end;

procedure Register;
begin
  RegisterComponents('Samples', [TSysTrayIcon]);
end;

end.