Компонент на основе TImageList позволяет использовать в приложении анимированные иконки

Previous  Top  Next

    
 

 

Code:

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.

 

Автор: Вадим Исаенко

WEB-сайт: http://v-isa.narod.ru

©Drkb::02366

http://delphiworld.narod.ru/

DelphiWorld 6.0