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.