1 {******************************************************************}
2 {*  IPANIM.PAS - Provides basic animation support. You should not *}
3 {*  need to create an instance of this class, instead you should  *}
4 {*  inherit your animated graphics class from this class.         *}
5 {******************************************************************}
6 
7 (* ***** BEGIN LICENSE BLOCK *****
8  * Version: MPL 1.1
9  *
10  * The contents of this file are subject to the Mozilla Public License Version
11  * 1.1 (the "License"); you may not use this file except in compliance with
12  * the License. You may obtain a copy of the License at
13  * http://www.mozilla.org/MPL/
14  *
15  * Software distributed under the License is distributed on an "AS IS" basis,
16  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
17  * for the specific language governing rights and limitations under the
18  * License.
19  *
20  * The Original Code is TurboPower Internet Professional
21  *
22  * The Initial Developer of the Original Code is
23  * TurboPower Software
24  *
25  * Portions created by the Initial Developer are Copyright (C) 2000-2002
26  * the Initial Developer. All Rights Reserved.
27  *
28  * Contributor(s):
29  *
30  * ***** END LICENSE BLOCK ***** *)
31 
32 { Global defines potentially affecting this unit }
33 {$I IPDEFINE.INC}
34 
35 unit IpAnim;
36 
37 interface
38 
39 uses
40   {$IFDEF IP_LAZARUS}
41   LCLType,
42   GraphType,
43   LCLIntf,
44   {$ELSE}
45   Windows,
46   Messages,
47   {$ENDIF}
48   SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
49   ExtCtrls, IpConst;
50 
51 const
52 
53   // Constants for the default settings of some properties
54 
55   DefaultAggressiveDrawing : Boolean = False;
56   DefaultFrameChangeNotify : Boolean = False;
57 
58 type
59 
60   // Various disposal methods
61 
62   TDisposalMethod = (NODISPOSALMETHOD, DONOTDISPOSE, OVERWRITEWITHBKGCOLOR,
63                      OVERWRITEWITHPREVIOUS);
64 
65   TIpAnimationFrameList = class;
66 
67   // Event Types
68 
69   TOnBeforeFrameChange = procedure (    Sender       : TObject;
70                                         CurrentFrame : Integer;
71                                     var NewFrame     : Integer;
72                                         Frames       : TIpAnimationFrameList;
73                                     var CanChange    : boolean) of object;
74 
75   TOnAfterFrameChange = procedure (Sender       : TObject;
76                                    CurrentFrame : Integer;
77                                    Frames       : TIpAnimationFrameList)
78                                        of object;
79 
80   // Exception Classes
81 
82   EAnimationError = class(Exception);             // GIF Decoding errors
83   EFrameListError = class (Exception);            // GIF Frame List errors
84 
85   // TIpAnimationFrame
86 
87   {
88     TIpAnimationFrame holds one frame of an animation.  It also keeps track
89     of the x and y offsets for the frame and the size of this frame.
90   }
91 
92   TIpAnimationFrame = class(TObject)
93 
94     private
95       FBitmap           : TBitmap;          // bitmap for this frame
96       FXOffset          : Integer;          // X Offset for this frame
97       FYOffset          : Integer;          // Y Offset for this frame
98       FDelayTime        : Integer;          // Time in 1/100 second til next frame
99       FDisposalMethod   : TDisposalMethod;  // Disposal Method
100       FTransparent      : Boolean;
101       FTransparentColor : TColor;
102 
103     protected
104 
105       procedure SetBitmap (v : TBitmap);
106       procedure SetDelayTime (v : Integer);
107       procedure SetXOffset (v : Integer);
108       procedure SetYOffset (v : Integer);
109 
110     public
111 
112       constructor Create;
113       destructor Destroy; override;
114 
115     published
116 
117       property Bitmap : TBitmap read FBitmap write SetBitmap;
118       property DelayTime : Integer read FDelayTime write SetDelayTime;
119       property DisposalMethod : TDisposalMethod
120                read FDisposalMethod write FDisposalMethod default DONOTDISPOSE;
121       property Transparent : Boolean
122                read FTransparent write FTransparent;
123       property TransparentColor : TColor
124                read FTransparentColor write FTransparentColor;
125       property XOffset : Integer read FXOffset write SetXOffset default 0;
126       property YOffset : Integer read FYOffset write SetYOffset default 0;
127 
128   end;
129 
130 
131   {
132     TIpAnimationFrameList holds a list of Frames.
133   }
134 
135    TIpAnimationFrameList = class(TObject)
136     private
137 
138       FReferenceCounter : Integer;    // Internal reference counter
139       FList : TList;
140 
141     protected
142 
GetCountnull143       function GetCount : Integer;
144       procedure SetCount (v : Integer);
GetItemnull145       function GetItem(Index : Integer): TIpAnimationFrame;
146       procedure SetItem(Index : Integer; AFrame : TIpAnimationFrame);
147       procedure RegisterFrames; virtual;
148       procedure ReleaseFrames; virtual;
149 
150     public
151       constructor Create;
152       destructor Destroy; override;
153 
154       // public methods
155 
Addnull156       function Add(AFrame : TIpAnimationFrame): Integer;
157       procedure Assign (Source : TIpAnimationFrameList); virtual;
158       procedure Clear;
IndexOfnull159       function IndexOf(AFrame : TIpAnimationFrame): Integer;
160       procedure Insert(Index : Integer; AFrame : TIpAnimationFrame);
Removenull161       function Remove(AFrame : TIpAnimationFrame): Integer;
162 
163       // properties
164 
165       property Count : Integer read GetCount write SetCount;
166       property Items[Index: Integer]: TIpAnimationFrame
167                read GetItem write SetItem; default;
168       property List : TList read FList write FList;
169 
170   end;
171 
172   {
173     TFreeGIFImage holds a decopressed GIF image.
174   }
175 
176   TIpAnimatedGraphic = class(TGraphic)
177 
178     private
179 
180       FNumFrames               : Integer;    // Number of frames in an animation
181       FAnimate                 : boolean;    // Animated image or not indicator
182       FRealWidth               : Integer;    // Real width of the image
183       FRealHeight              : Integer;    // Real height of the image
184 
185       FBitmap                  : TBitmap;    // bitmap of the current frame
186 
187       FDelayTime               : Integer;    // Delay in 100ths of a second
188       FCurrentFrame            : Integer;    // Index of the current frame
189       FDisposalMethod          : TDisposalMethod;    // Disposal method for the cur frm
190       FAggressiveDrawing       : Boolean;    // steal a canvas and write to it?
191       FFrameChangeNotify       : Boolean;    // trigger OnChange events?
192 
193       FTransparent             : Boolean;
194       FTransparentColor        : TColor;
195       FBackgroundColor         : TColor;
196 
197       FTimer                   : TTimer;     // Animation Timer
198       FImages                  : TIpAnimationFrameList;
199 
200       FOnBeforeFrameChange  : TOnBeforeFrameChange;
201       FOnAfterFrameChange   : TOnAfterFrameChange;
202 
203       FDrawingCanvas : TCanvas;     // Canvas that will be "stolen" for
204                                     // animation purposes.
205       FDrawingRect   : TRect;
206 
207       FDestinationCanvas : TCanvas; // User specified canvas to write to.
208       FDestinationRect   : TRect;   // User specified rectangle to write to.
209 
210     protected
211 
212       // Property Access
213 
214       procedure ChangeFrame (NewFrame : Integer); virtual;
215       procedure ClearFrame (    CurrentFrame   : TBitmap;
216                                 NewFrame       : TIpAnimationFrame;
217                                 DisposalMethod : TDisposalMethod;
218                             var DefaultDrawing : Boolean); virtual;
219       procedure Draw(      ACanvas : TCanvas;
220                      const Rect    : TRect); override;
221       procedure FreeAnimationFrames; virtual;
GetAnimatenull222       function GetAnimate : boolean;
GetEmptynull223       function GetEmpty : Boolean; override;
GetHeightnull224       function GetHeight : Integer; override;
GetWidthnull225       function GetWidth : Integer; override;
226       procedure Initialize; virtual;
227       procedure SetAggressiveDrawing (v : Boolean);
228       procedure SetAnimate (v : boolean);
229       procedure SetBitmap (v : TBitmap);
230       procedure SetDelayTime (v : Integer);
231       procedure SetDestinationCanvas (v : TCanvas);
232       procedure SetDestinationRect (v : TRect);
233       procedure SetDisposalMethod (v : TDisposalMethod);
234       procedure SetDrawingCanvas (v : TCanvas);
235       procedure SetDrawingRect (v : TRect);
236       procedure SetFrameChangeNotify (v : Boolean);
237       procedure SetHeight (v : Integer); override;
238       procedure SetImages (v : TIpAnimationFrameList);
239       procedure SetNumFrames (v : Integer);
240       procedure SetWidth (v : Integer); override;
241       procedure TimerTimeoutHandler (Sender : TObject); virtual;
242 
243     public
244 
245       constructor Create; override;
246       destructor Destroy; override;
247 
248       procedure Assign(Source : TPersistent); override;
249       procedure AssignTo (Dest : TPersistent); override;
250 
251       procedure LoadFromStream (Stream: TStream); override;
252 
StartAnimationnull253       function StartAnimation : boolean; virtual;
254       procedure StopAnimation; virtual;
255 
256 
257       // Properties
258 
259       property AggressiveDrawing : Boolean
260                read FAggressiveDrawing write SetAggressiveDrawing;
261       property Animate : boolean read GetAnimate write SetAnimate;
262       property BackgroundColor : TColor
263                read FBackgroundColor write FBackgroundColor;
264       property Bitmap : TBitmap read FBitmap write SetBitmap;
265       property CurrentFrameIndex : Integer read FCurrentFrame write ChangeFrame;
266       property DelayTime : Integer read FDelayTime write SetDelayTime;
267       property DestinationCanvas : TCanvas
268                read FDestinationCanvas write SetDestinationCanvas;
269       property DestinationRect : TRect
270                read FDestinationRect write SetDestinationRect;
271       property DrawingCanvas : TCanvas
272                read FDrawingCanvas write SetDrawingCanvas;
273       property DrawingRect : TRect
274                read FDrawingRect write SetDrawingRect;
275       property DisposalMethod : TDisposalMethod
276                read FDisposalMethod write SetDisposalMethod;
277       property FrameChangeNotify : Boolean
278                read FFrameChangeNotify  write SetFrameChangeNotify;
279       property Height : Integer read getHeight write setHeight;
280       property Images : TIpAnimationFrameList read FImages write SetImages;
281       property NumFrames : Integer read FNumFrames write SetNumFrames;
282       property Transparent : boolean read FTransparent write FTransparent;
283       property TransparentColor : TColor
284                read FTransparentColor write FTransparentColor;
285       property Width : Integer read getWidth write setWidth;
286 
287       // Events
288 
289       property OnAfterFrameChange : TOnAfterFrameChange
290                read FOnAfterFrameChange
291                write FOnAfterFrameChange;
292       property OnBeforeFrameChange : TOnBeforeFrameChange
293                read FOnBeforeFrameChange
294                write FOnBeforeFrameChange;
295     published
296 
297   end;
298 
299 implementation
300 
301 // TFreeGIFFrame
302 
303 constructor TIpAnimationFrame.Create;
304 begin
305   inherited Create;
306 
307   FBitmap := TBitmap.create;
308 
309   XOffset := 0;
310   YOffset := 0;
311   DisposalMethod := NODISPOSALMETHOD;
312 end;
313 
314 destructor TIpAnimationFrame.Destroy;
315 begin
316   FBitmap.Free;
317   FBitmap := nil;
318 
319   inherited Destroy;
320 end;
321 
322 procedure TIpAnimationFrame.SetBitmap (v : TBitmap);
323 begin
324   FBitmap.Assign (v);
325 end;
326 
327 procedure TIpAnimationFrame.SetDelayTime (v : Integer);
328 begin
329   if v <> FDelayTime then
330     FDelayTime := v;
331 end;
332 
333 procedure TIpAnimationFrame.SetXOffset (v : Integer);
334 begin
335   if v <> FXOffset then
336     FXOffset := v;
337 end;
338 
339 procedure TIpAnimationFrame.SetYOffset (v : Integer);
340 begin
341   if v <> FYOffset then
342     FYOffset := v;
343 end;
344 
345 // TIpAnimationFrameList
346 
347 constructor TIpAnimationFrameList.Create;
348 begin
349   inherited Create;
350 
351   FList := TList.Create;
352 
353   FReferenceCounter := 0;
354 end;
355 
356 destructor TIpAnimationFrameList.Destroy;
357 begin
358   FList.Free;
359   inherited Destroy;
360 end;
361 
Addnull362 function TIpAnimationFrameList.Add(AFrame : TIpAnimationFrame) : Integer;
363 begin
364   Result := FList.Add (AFrame)
365 end;
366 
367 procedure TIpAnimationFrameList.Assign (Source : TIpAnimationFrameList);
368 var
369   i : Integer;
370 begin
371   Clear;
372   FList.Capacity := Source.List.Capacity;
373   FList.Count := Source.List.Count;
374   for i := 0 to Source.List.Count - 1 do
375     FList.Items[i] := Source.List.Items[i];
376 
377   RegisterFrames;
378 end;
379 
380 procedure TIpAnimationFrameList.Clear;
381 begin
382   FList.Clear;
383 end;
384 
GetCountnull385 function TIpAnimationFrameList.GetCount : Integer;
386 begin
387   result := FList.Count;
388 end;
389 
GetItemnull390 function TIpAnimationFrameList.GetItem(Index : Integer) :
391                                        TIpAnimationFrame;
392 begin
393 
394   if (Index >= FList.Count) or (Index < 0) then begin
395     Result := nil;
396     Exit;
397   end;
398 
399   if (FList.Items[Index]=nil) then begin
400     Result := nil;
401     Exit;
402   end;
403 
404   if TObject (FList.Items[Index]) is TIpAnimationFrame then
405     Result := TObject (FList.Items[Index]) as TIpAnimationFrame
406   else
407     raise EFrameListError.CreateFmt(sBadFrameListObject,
408                                     [TObject(FList.Items[Index]).ClassName]);
409 end;
410 
TIpAnimationFrameList.IndexOfnull411 function TIpAnimationFrameList.IndexOf(AFrame : TIpAnimationFrame) : Integer;
412 begin
413   Result := FList.IndexOf (AFrame);
414 end;
415 
416 procedure TIpAnimationFrameList.Insert(Index  : Integer;
417                                        AFrame : TIpAnimationFrame);
418 begin
419   FList.Insert (Index, AFrame);
420 end;
421 
422 procedure TIpAnimationFrameList.RegisterFrames;
423 begin
424   inc(FReferenceCounter);
425 end;
426 
427 procedure TIpAnimationFrameList.ReleaseFrames;
428 var
429   i : Integer;
430 begin
431   dec (FReferenceCounter);
432   if FReferenceCounter >= 0 then
433     exit;
434 
435   for i := 0 to FList.Count - 1 do begin
436     if (FList.Items[i]<>nil) then
437       if TObject(FList.Items[i]) is TIpAnimationFrame then
438         TIpAnimationFrame (FList.Items[i]).Free;
439     FList.Items[i] := nil;
440   end;
441 
442   Clear;
443   FList.Count := 0;
444 end;
445 
TIpAnimationFrameList.Removenull446 function TIpAnimationFrameList.Remove(AFrame : TIpAnimationFrame) : Integer;
447 begin
448   Result := FList.Remove (AFrame);
449 end;
450 
451 procedure TIpAnimationFrameList.SetCount (v : Integer);
452 begin
453   if v <> FList.Count then
454     FList.Count := v;
455 end;
456 
457 procedure TIpAnimationFrameList.SetItem(Index  : Integer;
458                                         AFrame : TIpAnimationFrame);
459 begin
460   FList.Items[Index] := AFrame;
461 end;
462 
463 // TIpAnimatedGraphic
464 
465 constructor TIpAnimatedGraphic.Create;
466 begin
467   inherited Create;
468 
469   FBitmap := TBitmap.create;
470 
471   FImages := TIpAnimationFrameList.create;
472 
473   FTimer := TTimer.create(nil);
474   FTimer.Enabled := False;
475   FTImer.OnTimer := TimerTimeoutHandler;
476 
477   FDrawingCanvas := nil;
478   FDestinationCanvas := nil;
479 
480   FAggressiveDrawing := DefaultAggressiveDrawing;
481 
482   FFrameChangeNotify := DefaultFrameChangeNotify;
483 
484 end;
485 
486 destructor TIpAnimatedGraphic.Destroy;
487 begin
488   FTimer.Free;
489   FTimer := nil;
490 
491   FBitmap.Free;
492   FBitmap := nil;
493 
494   FreeAnimationFrames;
495 
496   FImages.Free;
497   FImages := nil;
498 
499   inherited Destroy;
500 end;
501 
502 procedure TIpAnimatedGraphic.Assign (Source : TPersistent);
503 begin
504   if Source is TIpAnimatedGraphic then
505     with Source as TIpAnimatedGraphic do begin
506       Self.Bitmap.assign(Bitmap);
507       Self.Images.Assign(Images);
508       Self.NumFrames         := NumFrames;
509       Self.Animate           := Animate;
510       Self.Width             := Width;
511       Self.Height            := Height;
512       Self.CurrentFrameIndex := 0;
513       Self.DelayTime         := DelayTime;
514       Self.DisposalMethod    := DisposalMethod;
515       Self.AggressiveDrawing := AggressiveDrawing;
516       Self.FrameChangeNotify := FrameChangeNotify;
517       Self.DrawingCanvas     := DrawingCanvas;
518     end
519   else
520     inherited Assign (Source);
521 end;
522 
523 procedure TIpAnimatedGraphic.AssignTo (Dest : TPersistent);
524 begin
525   if (Dest is TBitmap) then
526     Dest.Assign(Bitmap)
527   else
528     inherited AssignTo(Dest);
529 end;
530 
531 procedure TIpAnimatedGraphic.ChangeFrame (NewFrame : Integer);
532 var
533   DefaultDrawing : Boolean;
534 begin
535   if (NewFrame < 0) or (NewFrame >= NumFrames) then
536     exit;
537 
538   FCurrentFrame := NewFrame;
539 
540   FBitmap.Width := FRealWidth;
541   FBitmap.Height := FRealHeight;
542   DisposalMethod := Images[NewFrame].DisposalMethod;
543 
544   DefaultDrawing := True;
545   ClearFrame (FBitmap, Images[NewFrame],
546               Images[NewFrame].DisposalMethod, DefaultDrawing);
547 
548   if DefaultDrawing then
549     FBitmap.Canvas.CopyRect (Rect (Images[NewFrame].XOffset,
550                                    Images[NewFrame].YOffset,
551                                    Images[NewFrame].XOffset + Images[NewFrame].Bitmap.Width,
552                                    Images[NewFrame].YOffset + Images[NewFrame].Bitmap.Height),
553                              Images[NewFrame].Bitmap.Canvas,
554                              Rect (0,
555                                    0,
556                                    Images[NewFrame].Bitmap.Width,
557                                    Images[NewFrame].Bitmap.Height));
558 
559   if AggressiveDrawing then begin
560     if assigned(FDrawingCanvas) then begin
561       // Do a quick and dirty verification that the handle that we stole
562       // from the .Draw method is still good.  We do this by calling
563       // GetDeviceCaps with the handle and verifying that there is something
564       // there.  If this is ok, we can then update the bitmap with the next
565       // frame.
566       if GetDeviceCaps (FDrawingCanvas.Handle, HORZSIZE) <> 0 then begin
567         if Animate and Transparent then
568           FDrawingCanvas.CopyRect (FDrawingRect, FBitmap.Canvas,
569                                    Rect (0, 0,
570                                          FBitmap.Width,
571                                          FBitmap.Height))
572         else
573           Draw (FDrawingCanvas, FDrawingRect);
574       end;
575     end;
576   end;
577 
578   if assigned(FDestinationCanvas) then begin
579     if Animate and Transparent then
580       FDestinationCanvas.CopyRect (FDestinationRect, FBitmap.Canvas,
581                                    Rect (0, 0,
582                                          FBitmap.Width,
583                                          FBitmap.Height))
584     else
585       Draw (FDestinationCanvas, DestinationRect);
586   end;
587 
588   // An alternate way to cause the animation to occur is to use the OnChange
589   // event to notify the parent application that the image has changed.  The
590   // problem with this is that the resulting flicker is... severe....
591 
592   if (assigned (OnChange)) and FrameChangeNotify then
593     OnChange (self);
594 
595   if (assigned (FOnAfterFrameChange)) then
596     FOnAfterFrameChange (Self, NewFrame, Images);
597 
598 end;
599 
600 procedure TIpAnimatedGraphic.ClearFrame (    CurrentFrame   : TBitmap;
601                                              NewFrame       : TIpAnimationFrame;
602                                              DisposalMethod : TDisposalMethod;
603                                          var DefaultDrawing : Boolean);
604 var
605   i                  : Integer;
606   x, y               : Integer;
607   UseTransparentCopy : Boolean;
608 
609 begin
610   {$IFDEF IP_LAZARUS}
611   if (CurrentFrame=nil) then ;
612   {$ENDIF}
613   //  Basic clear frame.  This should work for just about anything.
614   DefaultDrawing := False;
615   UseTransparentCopy := False;
616 
617   case DisposalMethod of
618 
619     NODISPOSALMETHOD      :
620       // do nothing in this case - leave the old image
621       begin
622         UseTransparentCopy := NewFrame.Transparent;
623       end;
624 
625     DONOTDISPOSE          :
626       // do nothing in this case - leave the old image
627       begin
628         UseTransparentCopy := NewFrame.Transparent;
629       end;
630 
631     OVERWRITEWITHBKGCOLOR :
632       begin
633         // Fill with the background color
634         Bitmap.Canvas.Brush.Color := BackgroundColor;
635         Bitmap.Canvas.FillRect (Rect(NewFrame.XOffset,
636                                      NewFrame.YOffset,
637                                      NewFrame.XOffset + NewFrame.Bitmap.Width,
638                                      NewFrame.YOffset + NewFrame.Bitmap.Height));
639       end;
640     OVERWRITEWITHPREVIOUS :
641       // Try to find the last do not dispose frame and fill the canvas with
642       // that.
643       begin
644         i := CurrentFrameIndex;
645         while (i >= 0) and (FNumFrames > 1) and
646               (Images[i].DisposalMethod <> DONOTDISPOSE) do
647           dec (i);
648         if (i >= 0) and (i < FNumFrames) and (FNumFrames > 1) then begin
649           if Images[i].DisposalMethod = DONOTDISPOSE then
650             Bitmap.Canvas.CopyRect (Rect (Images[i].XOffset,
651                                         Images[i].YOffset,
652                                         Images[i].XOffset + Images[i].Bitmap.Width,
653                                         Images[i].YOffset + Images[i].Bitmap.Height),
654                                   Images[i].Bitmap.Canvas,
655                                   Rect (0,
656                                         0,
657                                         Images[i].Bitmap.Width,
658                                         Images[i].Bitmap.Height));
659             UseTransparentCopy := NewFrame.Transparent;
660           end
661         else
662           UseTransparentCopy := NewFrame.Transparent;
663       end;
664 
665   end;
666 
667   // This is not a generally recommended way of handling transparency.
668   // However, it gets the timing more accurate.
669 
670   if UseTransparentCopy then begin
671     if Images[FCurrentFrame].Bitmap <> nil then
672       for x := 0 to Images[FCurrentFrame].Bitmap.Width - 1 do
673         for y := 0 to Images[FCurrentFrame].Bitmap.Height - 1 do
674           if Images[FCurrentFrame].Bitmap.Canvas.Pixels[x, y] <>
675              Images[FCurrentFrame].TransparentColor then begin
676             if (x + Images[FCurrentFrame].XOffset < Bitmap.Width) and
677                (y + Images[FCurrentFrame].YOffset < Bitmap.Height) then
678               Bitmap.Canvas.Pixels[x + Images[FCurrentFrame].XOffset,
679                                    y + Images[FCurrentFrame].YOffset] :=
680                       Images[FCurrentFrame].Bitmap.Canvas.Pixels[x, y];
681           end;
682   end else
683     Bitmap.Canvas.CopyRect (Rect (NewFrame.XOffset,
684                                   NewFrame.YOffset,
685                                   NewFrame.XOffset + NewFrame.Bitmap.Width,
686                                   NewFrame.YOffset + NewFrame.Bitmap.Height),
687                             NewFrame.Bitmap.Canvas,
688                             Rect (0,
689                                   0,
690                                   NewFrame.Bitmap.Width,
691                                   NewFrame.Bitmap.Height));
692 
693 end;
694 
695 procedure TIpAnimatedGraphic.Draw(      ACanvas : TCanvas;
696                                   const Rect    : TRect);
697 begin
698 
699   // Since a TGraphic has no visible portion (for trapping paints) and no
700   // knowledge of what component owns it, the animation can be tricky.  This
701   // is resolved by "stealing" the canvas from wherever this graphic is going
702   // to be drawn and then using that canvas for the animation updates.
703 
704   if AggressiveDrawing then begin
705     DrawingCanvas := ACanvas;
706     DrawingRect := Rect;
707   end;
708 
709 end;
710 
711 procedure TIpAnimatedGraphic.FreeAnimationFrames;
712 begin
713   Images.ReleaseFrames;
714 end;
715 
GetAnimatenull716 function TIpAnimatedGraphic.GetAnimate : boolean;
717 begin
718   result := FAnimate;
719 end;
720 
TIpAnimatedGraphic.GetEmptynull721 function TIpAnimatedGraphic.GetEmpty : Boolean;
722 begin
723   result := (Height = 0) or (Width = 0);
724 end;
725 
TIpAnimatedGraphic.GetHeightnull726 function TIpAnimatedGraphic.GetHeight : Integer;
727 begin
728   Result := FRealHeight;
729 end;
730 
GetWidthnull731 function TIpAnimatedGraphic.GetWidth : Integer;
732 begin
733   result := FRealWidth;
734 end;
735 
736 procedure TIpAnimatedGraphic.Initialize;
737 begin
738   // Reset the frame count
739 
740   NumFrames := 0;
741   FCurrentFrame := 0;
742   Animate := False;
743 
744   // Free up any stray bitmaps
745 
746   FreeAnimationFrames;
747 
748 end;
749 
750 procedure TIpAnimatedGraphic.LoadFromStream (Stream: TStream);
751 {
752   LoadFromStream should never be called at this level.  The classes that
753   inherit from this class should implement their own load code.
754 
755   Should LoadFromStream get called, TIpAnimatedGraphic will create a default
756   image.
757 }
758 begin
759   {$IFDEF IP_LAZARUS}
760   if (Stream=nil) then ;
761   {$ENDIF}
762   Width := 50;
763   Height := 50;
764   Bitmap.Canvas.Brush.Color := clWhite;
765   Bitmap.Canvas.FillRect (Rect (0, 0, 49, 49));
766   Bitmap.Canvas.Pen.Color := clRed;
767   Bitmap.Canvas.TextOut (0, 0, 'X');
768 end;
769 
770 procedure TIpAnimatedGraphic.SetAggressiveDrawing (v : Boolean);
771 begin
772   if v <> FAggressiveDrawing then
773     FAggressiveDrawing := v;
774 end;
775 
776 procedure TIpAnimatedGraphic.SetAnimate (v : boolean);
777 begin
778   if v <> FAnimate then begin
779     if v then
780       FAnimate := StartAnimation
781     else begin
782       FAnimate := False;
783       StopAnimation;
784     end;
785   end;
786 end;
787 
788 procedure TIpAnimatedGraphic.SetBitmap (v : TBitmap);
789 begin
790   FBitmap.Assign (v);
791 end;
792 
793 procedure TIpAnimatedGraphic.SetDelayTime (v : Integer);
794 begin
795   if v <> FDelayTime then
796     FDelayTime := v;
797 end;
798 
799 procedure TIpAnimatedGraphic.SetDestinationCanvas (v : TCanvas);
800 begin
801 
802   // Destination Canvas is a weird property. It IS the canvas to which the
803   // drawing will take place.  We use := to assign it.
804 
805   if v <> FDestinationCanvas then
806     FDestinationCanvas := v;
807 end;
808 
809 procedure TIpAnimatedGraphic.SetDestinationRect (v : TRect);
810 begin
811   FDestinationRect := v;
812 end;
813 
814 procedure TIpAnimatedGraphic.SetDisposalMethod (v : TDisposalMethod);
815 begin
816   if v <> FDisposalMethod then
817     FDisposalMethod := v;
818 end;
819 
820 procedure TIpAnimatedGraphic.SetDrawingCanvas (v : TCanvas);
821 begin
822 
823   // Drawing Canvas is a weird property. It IS the canvas to which the drawing
824   // will take place.  We use := to assign it.
825 
826   if v <> FDrawingCanvas then
827     FDrawingCanvas := v;
828 end;
829 
830 procedure TIpAnimatedGraphic.SetDrawingRect (v : TRect);
831 begin
832 
833   // Drawing Rect is a weird property. It IS the rectangle on the canvas to
834   // hich the drawing will take place.  We use := to assign it.
835 
836   FDrawingRect := v;
837 end;
838 
839 procedure TIpAnimatedGraphic.SetFrameChangeNotify (v : Boolean);
840 begin
841   if v <> FFrameChangeNotify then
842     FFrameChangeNotify  := v;
843 end;
844 
845 procedure TIpAnimatedGraphic.SetHeight(v : Integer);
846 begin
847   if v <> FRealHeight then begin
848     FBitmap.height := v;
849     FRealHeight := v;
850   end;
851 end;
852 
853 procedure TIpAnimatedGraphic.SetImages (v : TIpAnimationFrameList);
854 var
855   i : integer;
856 begin
857   FImages.List.Clear;
858   FImages.List.Capacity := v.List.Capacity;
859   FImages.List.Count := v.List.Count;
860   for i := 0 to v.List.Count - 1 do
861     FImages.List.Add(v.List[i]);
862 end;
863 
864 procedure TIpAnimatedGraphic.SetNumFrames (v : Integer);
865 begin
866   if v <> FNumFrames then
867     FNumFrames := v;
868 end;
869 
870 procedure TIpAnimatedGraphic.SetWidth(v : Integer);
871 begin
872   if v <> FRealWidth then begin
873     FBitmap.Width := v;
874     FRealWidth := v;
875   end;
876 end;
877 
StartAnimationnull878 function TIpAnimatedGraphic.StartAnimation : boolean;
879 begin
880   Result := True;
881   FTimer.Enabled := False;
882   if NumFrames > 1 then begin
883     if FDelayTime <= 1 then
884       FTimer.Interval := 100
885     else
886       FTimer.Interval := Images[0].DelayTime * 10;
887     FTimer.Enabled := True;
888   end else
889     Result := False;
890 end;
891 
892 procedure TIpAnimatedGraphic.StopAnimation;
893 begin
894   FTimer.Enabled := False;
895 end;
896 
897 procedure TIpAnimatedGraphic.TimerTimeoutHandler (Sender : TObject);
898 var
899   NewFrame  : Integer;
900   CanChange : Boolean;
901 
902 begin
903   if NumFrames < 1 then
904     exit;
905 
906   FTimer.Enabled := False;
907   try
908     NewFrame := FCurrentFrame;
909 
910     Inc (NewFrame);
911     if (NewFrame >= NumFrames) then
912       NewFrame := 0;
913 
914     CanChange := True;
915     if Assigned (FOnBeforeFrameChange) then
916       FOnBeforeFrameChange (self,
917                             FCurrentFrame,
918                             NewFrame,
919                             Images,
920                             CanChange);
921 
922     if CanChange then
923       ChangeFrame (NewFrame);
924 
925     if NumFrames >= 1 then begin
926       FTimer.Interval := Images[FCurrentFrame].DelayTime * 10;
927       if FTImer.Interval < 10 then
928         FTImer.Interval := 50;
929     end else
930       FTimer.Interval := 32767;
931 
932   finally
933     FTimer.Enabled := True;
934   end;
935 end;
936 
937 end.
938