aniicons.pas

Delphi 开发的的热键操作 很值得看的

unit AniIcons;

interface

uses Windows, Classes, Graphics, SysUtils, TmrPool;

type
  EIconListError = class(Exception);
  
  TNewFrameEvent = procedure(Sender: TObject; Frame: Integer) of object;

  TIconSize = (is16x16, is32x32);

  TAnimatedIcons = class;

  TAnimatedIcon = class(TIcon)
  private
    FDisplayTime: Longint;
  public
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property DisplayTime: Longint read FDisplayTime write FDisplayTime;
  end;

  TAnimatedIcons = class(TPersistent)
  private
    { property variables }
    FAuthor       : String;
    FIcons        : TList;
    FIconIndex    : Integer;
    FIconSize     : TIconSize;
    FPlaying      : Boolean;
    FTitle        : String;
    { Event variables }
    FOnNewFrame   : TNewFrameEvent;
    FOnStopped    : TNotifyEvent;
    { Private variables }
    FBrush        : TBrush;
    FDrawSize     : Integer;
    FCurrentTiming: Integer;
    FCurrentLoop  : Integer;
    FTotalLoops   : Integer;
    { Private routines (property get/set) }
    procedure SetIconIndex(Value: Integer);
    { Private routines (object streaming) }
    procedure WriteString(Stream: TStream; Value: String);
    function  ReadString(Stream: TStream): String;
    procedure ReadData(Stream: TStream);
    procedure WriteData(Stream: TStream);
  protected
    { Protected routines }
    procedure cmTimerElapsed(var Msg: TCMTimerElapsed); message CM_TIMERELAPSED;
    procedure SetDrawSize;
    procedure DefineProperties(Filer: TFiler); override;
    function  Get(Index: Integer): TAnimatedIcon;
    function  GetCount: Integer;
    procedure Put(Index: Integer; const Icon: TAnimatedIcon);
  public
    { constructor / destructor }
    constructor Create(Size: TIconSize);
    destructor Destroy; override;
    { public methods }
    function  Add(const Icon: TAnimatedIcon): Integer;
    function  AddIcon: TAnimatedIcon;
    procedure AddIcons(Icons: TAnimatedIcons);
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
    procedure Delete(Index: Integer);
    function  Equals(Icons: TAnimatedIcons): Boolean;
    procedure Exchange(Index1, Index2: Integer);
    procedure Insert(Index: Integer; const Icon: TAnimatedIcon);
    procedure Move(CurIndex, NewIndex: Integer);
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    procedure Play(NrOfTimes: Integer);
    procedure Stop;
    procedure DrawIcon(Canvas: TCanvas; X, Y, Index: Integer; MaskColor: TColor);
    { properties }
    property  Count: Integer read GetCount;
    property  IconIndex: Integer read FIconIndex write SetIconIndex;
    property  IconSize: TIconSize read FIconSize;
    property  Icons[Index: Integer]: TAnimatedIcon read Get write Put; default;
  published
    property  Author: String read FAuthor write FAuthor;
    property  Playing: Boolean read FPlaying default False;
    property  Title: String read FTitle write FTitle;
    { animation event }
    property  OnNewFrame: TNewFrameEvent read FOnNewFrame write FOnNewFrame;
    property  OnStopped: TNotifyEvent read FOnStopped write FOnStopped;
  end;

implementation

{ TAnimatedIcon }
procedure TAnimatedIcon.Assign(Source: TPersistent);
begin
  if Source is TAnimatedIcon then DisplayTime := TAnimatedIcon(Source).DisplayTime;
  inherited Assign(Source);
end;

procedure TAnimatedIcon.LoadFromStream(Stream: TStream);
var
  MStream: TMemoryStream;
  lSize  : Longint;
  P      : PChar;
begin
  Stream.Read(FDisplayTime, sizeof(Longint));
  Stream.Read(lSize, sizeof(Longint));
  if lSize>0 then
   begin
     MStream := TMemoryStream.Create;
     try
       P := StrAlloc(lSize+1);
       try
         Stream.Read(P^, lSize);
         MStream.Write(P^, lSize);
       finally
         StrDispose(P);
       end;
       MStream.Position := 0;
       inherited LoadFromStream(MStream);
     finally
       MStream.Free;
     end;
  end;
end;

procedure TAnimatedIcon.SaveToStream(Stream: TStream);
var
  MStream: TMemoryStream;
  lSize  : Longint;
  P      : PChar;
begin
  Stream.Write(FDisplayTime, sizeof(Longint));
  MStream := TMemoryStream.Create;
  try
    inherited SaveToStream(MStream);
    lSize := MStream.Size;
    Stream.Write(lSize, sizeof(LongInt));
    MStream.Position := 0;
    P := StrAlloc(lSize+1);
    try
      MStream.Read(P^, lSize);
      Stream.Write(P^, lSize);
    finally
      StrDispose(P);
    end;
  finally
    MStream.Free;
  end;
end;

{ TAnimatedIcons }
constructor TAnimatedIcons.Create(Size: TIconSize);
begin
  inherited Create;
  FIconSize := Size;
  SetDrawSize;
  FIcons := TList.Create;
  FBrush := TBrush.Create;
  TimerPool.NotifyRegister(Self, False);
end;

destructor TAnimatedIcons.Destroy;
begin
  TimerPool.NotifyUnregister(Self);
  Clear;
  FIcons.Free;
  FBrush.Free;
  inherited Destroy;
end;

procedure TAnimatedIcons.SetIconIndex(Value: Integer);
begin
  if FIconIndex<>Value then
   begin
     if (Value>=0) and (Value<Count) then
      FIconIndex := Value
     else
      raise EIconListError.Create('Icon list index out of bounds');
   end;
end;

function TAnimatedIcons.Add(const Icon: TAnimatedIcon): Integer;
begin
  Result := GetCount;
  Insert(Result, Icon);
end;

function TAnimatedIcons.AddIcon: TAnimatedIcon;
begin
  Result := TAnimatedIcon.Create;
  FIcons.Add(Result);
end;

procedure TAnimatedIcons.AddIcons(Icons: TAnimatedIcons);
var
  I: Integer;
begin
  for I := 0 to Icons.Count - 1 do Add(Icons[I]);
end;

procedure TAnimatedIcons.Assign(Source: TPersistent);
begin
  if Source is TAnimatedIcons then
   begin
     FAuthor := TAnimatedIcons(Source).Author;
     FTitle := TAnimatedIcons(Source).Title;
     FIconSize := TAnimatedIcons(Source).IconSize;
     SetDrawSize;
     Clear;
     AddIcons(TAnimatedIcons(Source));
   end
  else
   inherited Assign(Source);
end;

procedure TAnimatedIcons.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
    begin
      Result := True;
      if Filer.Ancestor is TAnimatedIcons then
        Result := not Equals(TAnimatedIcons(Filer.Ancestor))
    end
    else Result := Count > 0;
  end;

begin
  Filer.DefineBinaryProperty('Icons', ReadData, WriteData, DoWrite);
end;

function TAnimatedIcons.Equals(Icons: TAnimatedIcons): Boolean;
var
  I, Count: Integer;
begin
  Result := False;
  Count := GetCount;
  if Count <> Icons.GetCount then Exit;
  for I := 0 to Count - 1 do if Get(I) <> Icons.Get(I) then Exit;
  Result := True;
end;

procedure TAnimatedIcons.Exchange(Index1, Index2: Integer);
begin
  FIcons.Exchange(Index1, Index2);
end;

procedure TAnimatedIcons.Move(CurIndex, NewIndex: Integer);
begin
  FIcons.Move(CurIndex, NewIndex);
end;

function TAnimatedIcons.GetCount: Integer;
begin
  Result := FIcons.Count;
end;

function TAnimatedIcons.Get(Index: Integer): TAnimatedIcon;
begin
  Result := TAnimatedIcon(FIcons[Index]);
end;

procedure TAnimatedIcons.Put(Index: Integer; const Icon: TAnimatedIcon);
begin
  Delete(Index);
  Insert(Index, Icon);
end;

procedure TAnimatedIcons.Clear;
begin
  while Count>0 do Delete(0);
end;

procedure TAnimatedIcons.Delete(Index: Integer);
begin
  TAnimatedIcon(FIcons[Index]).Free;
  FIcons.Delete(Index);
  FIcons.Pack;
end;

procedure TAnimatedIcons.Insert(Index: Integer; const Icon: TAnimatedIcon);
var
  NewIcon: TAnimatedIcon;
begin
  NewIcon := TAnimatedIcon.Create;
  NewIcon.Assign(Icon);
  FIcons.Insert(Index, NewIcon);
end;

procedure TAnimatedIcons.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

function TAnimatedIcons.ReadString(Stream: TStream): String;
var
  i, iCount : Integer;
  cLetter   : Char;
begin
  Result := '';
  with Stream do
   begin
     Read(iCount, sizeof(Longint));
     for i:=1 to iCount do
      begin
        Read(cLetter, sizeof(Char));
        Result := Result + cLetter;
      end;
   end;
end;

procedure TAnimatedIcons.WriteString(Stream: TStream; Value: String);
var
  i, iCount : Integer;
begin
  iCount := Length(Value);
  with Stream do
   begin
     Write(iCount, sizeof(Longint));
     for i:=1 to iCount do
      Write(Value[i], sizeof(Char));
   end;
end;

procedure TAnimatedIcons.LoadFromStream(Stream: TStream);
var
  i, iCount: Longint;
begin
  FTitle := ReadString(Stream);
  FAuthor := ReadString(Stream);
  Stream.Read(FIconSize, sizeof(TIconSize));
  SetDrawSize;
  Stream.Read(iCount, sizeof(LongInt));
  Clear;
  for i:=0 to iCount-1 do
   AddIcon.LoadFromStream(Stream);
end;

procedure TAnimatedIcons.ReadData(Stream: TStream);
begin
  LoadFromStream(Stream);
end;

procedure TAnimatedIcons.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TAnimatedIcons.SaveToStream(Stream: TStream);
var
  i, iCount: Integer;
begin
  iCount := Count;
  WriteString(Stream, FTitle);
  WriteString(Stream, FAuthor);
  Stream.Write(FIconSize, sizeof(TIconSize));
  Stream.Write(iCount, sizeof(LongInt));
  for I := 0 to iCount - 1 do
   Icons[I].SaveToStream(Stream);
end;

procedure TAnimatedIcons.WriteData(Stream: TStream);
begin
  SaveToStream(Stream);
end;

procedure TAnimatedIcons.cmTimerElapsed(var Msg: TCMTimerElapsed);
begin
  if (FIconIndex>=FIcons.Count) then
   begin
     FIconIndex := 0;
     if (FIcons.Count = 0) then Exit;
   end;
  inc(FCurrentTiming, Msg.MilliSeconds);
  if FCurrentTiming>=Icons[FIconIndex].DisplayTime*10 then
   begin
     if Assigned(FOnNewFrame) then FOnNewFrame(Self, FIconIndex);
     inc(FIconIndex);
     if FIconIndex>=Count then
      begin
        FIconIndex := 0;
        if FTotalLoops>0 then
         begin
           inc(FCurrentLoop);
           if FCurrentLoop = FTotalLoops then Stop;
         end;
      end;
     FCurrentTiming := 0;
   end;
end;

procedure TAnimatedIcons.Play(NrOfTimes: Integer);
begin
  if not Assigned(FOnNewFrame) or (Count=0) then Exit;
  FIconIndex := 0;
  FCurrentTiming := 0;
  FPlaying := True;
  FTotalLoops := NrOfTimes;
  FCurrentLoop := 0;
  TimerPool.NotifyRegister(Self, True);
end;

procedure TAnimatedIcons.Stop;
begin
  TimerPool.NotifyRegister(Self, False);
  FPlaying := False;
  if Assigned(FOnStopped) then FOnStopped(Self);
end;

procedure TAnimatedIcons.SetDrawSize;
begin
  if FIconSize=is16x16 then FDrawSize := 16 else FDrawSize := 32;
end;

procedure TAnimatedIcons.DrawIcon(Canvas: TCanvas; X, Y, Index: Integer; MaskColor: TColor);
begin
  if not Assigned(Canvas) then Exit;
  if (Index>=0) and (Index<FIcons.Count) then
   begin
     FBrush.Color := MaskColor;
     DrawIconEx(Canvas.Handle, X, Y, TIcon(FIcons[Index]).Handle, FDrawSize, FDrawSize, 0,
                FBrush.Handle, DI_NORMAL);
   end;
end;

end.