unit AnimIcon;

interface

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

const
  WM_FROMTRAYICON = WM_USER+59;

type
  TIconPlace = (ipAppIcon,ipAppMainFormIcon,ipFormIcon,ipImageCtrl,ipSysTray);
  TOnTimerEventOrder = (First,Second);
  TIconPlaceSet=Set Of TIconPlace;
  TTimerEvent=procedure(Sender:TObject) of object;
  TAnimIcon = class(TImageList)

  private
    { Private declarations }
    FIconPlaceSet:TIconPlaceSet;
    FEnabled:Boolean;
    FInterval:Cardinal;
    FNumIco:Integer;
    FOnTimer:TTimerEvent;
    FImage:TImage;
    FAuthor:String;
    FTip:String;
    FActionForIconOnSysTray:Byte;
    FOnTimerEventOrder:TOnTimerEventOrder;
    FhWnd : hWnd;
    procedure PlaceIcon;
  protected
    { Protected declarations }
    procedure Loaded;override;
    procedure SetEnabled(Value:Boolean);
    function GetEnabled:Boolean;
    procedure SetInterval(Value:Cardinal);
    function GetInterval:Cardinal;
    procedure OnAnimIconTimer(Sender: TObject);
    procedure SetImage(Value:TImage);
    function GetImage:TImage;
    procedure SetAuthor(Value:String);
  public
    { Public declarations }
  published
    { Published declarations }
    constructor Create(AOwner:Tcomponent);override; //Конструктор
    destructor Destroy;override;
    property IconPlace: TIconPlaceSet Read FIconPlaceSet Write FIconPlaceSet;
    property Enabled:Boolean Read GetEnabled Write SetEnabled;
    property Interval:Cardinal Read GetInterval Write SetInterval;
    property OnTimer: TTimerEvent Read FOnTimer Write FOnTimer;
    property ImageCtrl: TImage Read GetImage Write SetImage;
    property Author:String Read FAuthor Write SetAuthor;
    property SysTrayTip:String Read FTip Write FTip;
    property OnTimerEventOrder:TOnTimerEventOrder Read FOnTimerEventOrder Write FOnTimerEventOrder;
  end;

var
  Timer:TTimer;

procedure Register;
function SysTrayIcon(hWindow:THandle; ID:Cardinal; ICON:hicon; CallbackMessage:Cardinal; Tip:String; Action:Byte):Boolean;

implementation

procedure Register;
begin
  RegisterComponents('MyComponents', [TAnimIcon]);
end;

function SysTrayIcon(hWindow:THandle; ID:Cardinal; Icon:hicon; CallbackMessage:Cardinal; Tip:String; Action:Byte):Boolean;
Var
 NID : TNotifyIconData;
Begin
 FillChar(NID, SizeOf(TNotifyIconData), 0);
 with NID do begin
  cbSize := SizeOf(TNotifyIconData);
  Wnd:=hWindow;
  uID:=ID;
  uFlags:=NIF_MESSAGE or NIF_ICON or NIF_TIP;
  uCallbackMessage:=CallbackMessage;
  hIcon:=Icon;
  If Length(Tip)>63 Then SetLength(Tip,63);
  StrPCopy(szTip, Tip);
  end;
 Case Action Of
   1:Result := Shell_NotifyIcon( NIM_ADD, @NID );
   2:Result := Shell_NotifyIcon(NIM_MODIFY, @NID );
   3:Result := Shell_NotifyIcon( NIM_DELETE, @NID );
  Else Result := False;
 End;
End;

procedure TAnimIcon.PlaceIcon;
Var
  Icon:TIcon;
  CallbackMessage:Cardinal;
Begin
  Inc(FNumIco);
  If FNumIco>Count Then FNumIco:=1;
  If ipAppIcon In FIconPlaceSet Then
    Begin
      GetIcon(FNumIco-1, Application.Icon);
      Application.ProcessMessages;
    End;
  If ipFormIcon In FIconPlaceSet Then
    Begin
      GetIcon(FNumIco-1,TForm(Owner).Icon);
      Application.ProcessMessages;
    End;
  If ipAppMainFormIcon In FIconPlaceSet Then
    Begin
      If Assigned(Application.MainForm) Then
        GetIcon(FNumIco-1,Application.MainForm.Icon);
      Application.ProcessMessages;
    End;
  If ipImageCtrl In FIconPlaceSet Then
    Begin
      If FImage <> nil Then
        GetIcon(FNumIco-1,FImage.Picture.Icon);
        Application.ProcessMessages;
    End;
  If ipSysTray In FIconPlaceSet Then
    Begin
      Icon:=TIcon.Create;
      GetIcon(FNumIco-1,Icon);
      CallbackMessage := WM_FROMTRAYICON;
      SysTrayIcon(FhWnd,0,Icon.Handle,CallbackMessage,FTip,FActionForIconOnSysTray);
      Application.ProcessMessages;
      If FActionForIconOnSysTray=1 Then FActionForIconOnSysTray:=2;
    End;
End;

constructor TAnimIcon.Create(AOwner:TComponent);
begin
 inherited create(AOwner);
 FAuthor:='V-Isa aka Inter';
 FNumIco:=0;
 Timer:=TTimer.Create(Self);
 Application.ProcessMessages;
 SetEnabled(False);
 SetInterval(1000);
 Timer.OnTimer:=OnAnimIconTimer;
 FActionForIconOnSysTray:=0;
 FOnTimerEventOrder:=First;
 If csDesigning in ComponentState Then FTip:=(Owner as TForm).Caption;
end;

destructor TAnimIcon.Destroy;
Var
  Icon:TIcon;
  CallbackMessage:Cardinal;
begin
 If ipSysTray In FIconPlaceSet Then
    Begin
      Icon:=TIcon.Create;
      CallbackMessage := WM_FROMTRAYICON;
      SysTrayIcon(FhWnd,0,Icon.Handle,CallbackMessage,FTip,3);
      Application.ProcessMessages;
    End;
 FNumIco:=0;
 FEnabled:=False;
 Timer.Enabled:=FEnabled;
 Application.ProcessMessages;
 inherited destroy;
end;

procedure TAnimIcon.OnAnimIconTimer(Sender: TObject);
begin
  if Assigned(FOnTimer) And (FOnTimerEventOrder=First) then FOnTimer(Self);
  Application.ProcessMessages;
  If Count>0 Then
    Begin
      PlaceIcon;
    End;
  Application.ProcessMessages;
  if Assigned(FOnTimer) And (FOnTimerEventOrder=Second) then FOnTimer(Self);
  Application.ProcessMessages;
end;

procedure TAnimIcon.SetEnabled(Value:Boolean);
begin
  If (Value=True) And (csDesigning in ComponentState) Then
    Begin
      Value:=False;
      FNumIco:=0;
      FEnabled:=Value;
      Timer.Enabled:=FEnabled;
      Application.ProcessMessages;
      ShowMessage('Изменение данного свойства возможно только'+#13'во время выполнения программы!!!');
      Exit;
    End;
  If (Value=True) And (Count>0) Then
    Begin
      FActionForIconOnSysTray:=1;
      PlaceIcon;
    End;
  If Value=False Then
    Begin
      FActionForIconOnSysTray:=3;
      PlaceIcon;
    End;
  Application.ProcessMessages;
  If Value=False Then FNumIco:=0;
  FEnabled:=Value;
  Timer.Enabled:=FEnabled;
  Application.ProcessMessages;
end;

function TAnimIcon.GetEnabled:Boolean;
begin
  GetEnabled:=FEnabled;
end;

procedure TAnimIcon.SetInterval(Value:Cardinal);
Begin
  FInterval:=Value;
  Timer.Interval:=FInterval;
  Application.ProcessMessages;
End;

function TAnimIcon.GetInterval:Cardinal;
Begin
  GetInterval:=FInterval;
End;

procedure TAnimIcon.SetImage(Value:TImage);
begin
  FImage:=Value;
end;

function TAnimIcon.GetImage:TImage;
begin
  GetImage:=FImage;
end;

procedure TAnimIcon.SetAuthor(Value:String);
begin
  FAuthor:='V-Isa aka Inter';
end;

procedure TAnimIcon.Loaded;
Begin
  inherited Loaded;
  FhWnd:=(Owner as TForm).Handle;
End;

end.