source: trunk/Packages/bgracontrols/bgraspriteanimation.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 15.9 KB
Line 
1unit BGRASpriteAnimation;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, Controls, Dialogs, ExtCtrls, Forms, Graphics, LCLIntF, LResources,
9 BGRABitmap, BGRABitmapTypes, BCTypes, BGRAAnimatedGif;
10
11type
12
13 TFlipMode = (flNone, flHorizontal, flVertical, flBoth);
14 TRotationMode = (rtNone, rtClockWise, rtCounterClockWise);
15
16 { TBGRASpriteAnimation }
17
18 TBGRASpriteAnimation = class(TGraphicControl)
19 private
20 { Private declarations }
21 FAnimInvert: boolean;
22 FAnimPosition: cardinal;
23 FAnimRepeat: cardinal;
24 FAnimRepeatLap: cardinal;
25 FAnimSpeed: cardinal;
26 FAnimStatic: boolean;
27 FAnimTimer: TTimer;
28 FAutoSize: boolean;
29 FCenter: boolean;
30 FOnLapChanged: TNotifyEvent;
31 FOnLapChanging: TNotifyEvent;
32 FOnPositionChanged: TNotifyEvent;
33 FOnPositionChanging: TNotifyEvent;
34 FOnRedrawAfter: TBGRARedrawEvent;
35 FOnRedrawBefore: TBGRARedrawEvent;
36 FProportional: boolean;
37 FSprite: TBitmap;
38 FSpriteCount: cardinal;
39 FSpriteFillOpacity: byte;
40 FSpriteFlipMode: TFlipMode;
41 FSpriteKeyColor: TColor;
42 FSpriteResampleFilter: TResampleFilter;
43 FSpriteResampleMode: TResampleMode;
44 FSpriteRotation: TRotationMode;
45 FStretch: boolean;
46 FTile: boolean;
47 function DoCalculateDestRect(AWidth, AHeight: integer): TRect;
48 function DoCalculatePosition(AValue: integer): integer;
49 function DoCalculateSize(AValue: cardinal): cardinal;
50 procedure DoAnimTimerOnTimer(Sender: TObject);
51 procedure DoSpriteDraw(ABitmap: TBGRABitmap);
52 procedure DoSpriteFillOpacity(ABitmap: TBGRABitmap);
53 procedure DoSpriteFlip(ABitmap: TBGRABitmap);
54 procedure DoSpriteKeyColor(ABitmap: TBGRABitmap);
55 procedure DoSpriteResampleFilter(ABitmap: TBGRABitmap);
56 procedure SetFAnimInvert(const AValue: boolean);
57 procedure SetFAnimPosition(const AValue: cardinal);
58 procedure SetFAnimRepeat(const AValue: cardinal);
59 procedure SetFAnimRepeatLap(const AValue: cardinal);
60 procedure SetFAnimSpeed(const AValue: cardinal);
61 procedure SetFAnimStatic(const AValue: boolean);
62 procedure SetFAutoSize(const AValue: boolean);
63 procedure SetFCenter(const AValue: boolean);
64 procedure SetFProportional(const AValue: boolean);
65 procedure SetFSprite(const AValue: TBitmap);
66 procedure SetFSpriteCount(const AValue: cardinal);
67 procedure SetFSpriteFillOpacity(const AValue: byte);
68 procedure SetFSpriteFlipMode(const AValue: TFlipMode);
69 procedure SetFSpriteKeyColor(const AValue: TColor);
70 procedure SetFSpriteResampleFilter(const AValue: TResampleFilter);
71 procedure SetFSpriteResampleMode(const AValue: TResampleMode);
72 procedure SetFSpriteRotation(const AValue: TRotationMode);
73 procedure SetFStretch(const AValue: boolean);
74 procedure SetFTile(const AValue: boolean);
75 protected
76 { Protected declarations }
77 procedure Paint; override;
78 public
79 { Public declarations }
80 function AnimatedGifToSprite(Filename: string): TBGRABitmap;
81 constructor Create(AOwner: TComponent); override;
82 destructor Destroy; override;
83 published
84 { Published declarations }
85 property AnimInvert: boolean Read FAnimInvert Write SetFAnimInvert;
86 property AnimPosition: cardinal Read FAnimPosition Write SetFAnimPosition;
87 property AnimRepeat: cardinal Read FAnimRepeat Write SetFAnimRepeat;
88 property AnimRepeatLap: cardinal Read FAnimRepeatLap Write SetFAnimRepeatLap;
89 property AnimSpeed: cardinal Read FAnimSpeed Write SetFAnimSpeed;
90 property AnimStatic: boolean Read FAnimStatic Write SetFAnimStatic;
91 property AutoSize: boolean Read FAutoSize Write SetFAutoSize; // to be implemented
92 property Center: boolean Read FCenter Write SetFCenter;
93 property Proportional: boolean Read FProportional Write SetFProportional;
94 property Sprite: TBitmap Read FSprite Write SetFSprite;
95 property SpriteCount: cardinal Read FSpriteCount Write SetFSpriteCount;
96 property SpriteFillOpacity: byte Read FSpriteFillOpacity Write SetFSpriteFillOpacity;
97 property SpriteFlipMode: TFlipMode Read FSpriteFlipMode Write SetFSpriteFlipMode;
98 property SpriteKeyColor: TColor Read FSpriteKeyColor Write SetFSpriteKeyColor;
99 property SpriteResampleFilter: TResampleFilter
100 Read FSpriteResampleFilter Write SetFSpriteResampleFilter;
101 property SpriteResampleMode: TResampleMode
102 Read FSpriteResampleMode Write SetFSpriteResampleMode;
103 property SpriteRotation: TRotationMode Read FSpriteRotation Write SetFSpriteRotation;
104 property Stretch: boolean Read FStretch Write SetFStretch;
105 property Tile: boolean Read FTile Write SetFTile;
106 published
107 property Align;
108 property Anchors;
109 property Caption;
110 property Enabled;
111 property OnClick;
112 property OnDblClick;
113 property OnLapChanged: TNotifyEvent Read FOnLapChanged Write FOnLapChanged;
114 property OnLapChanging: TNotifyEvent Read FOnLapChanging Write FOnLapChanging;
115 property OnMouseDown;
116 property OnMouseEnter;
117 property OnMouseLeave;
118 property OnMouseMove;
119 property OnMouseUp;
120 property OnPositionChanged: TNotifyEvent
121 Read FOnPositionChanged Write FOnPositionChanged;
122 property OnPositionChanging: TNotifyEvent
123 Read FOnPositionChanging Write FOnPositionChanging;
124 property OnRedrawAfter: TBGRARedrawEvent Read FOnRedrawAfter Write FOnRedrawAfter;
125 property OnRedrawBefore: TBGRARedrawEvent Read FOnRedrawBefore Write FOnRedrawBefore;
126 property PopupMenu;
127 property Visible;
128 end;
129
130procedure Register;
131
132implementation
133
134procedure Register;
135begin
136 {$I bgraspriteanimation_icon.lrs}
137 RegisterComponents('BGRA Controls', [TBGRASpriteAnimation]);
138end;
139
140{ TBGRASpriteAnimation }
141
142{ Animation Variables }
143
144procedure TBGRASpriteAnimation.SetFAnimInvert(const AValue: boolean);
145begin
146 if FAnimInvert = AValue then
147 Exit;
148 FAnimInvert := AValue;
149
150 if csDesigning in ComponentState then
151 Invalidate;
152end;
153
154procedure TBGRASpriteAnimation.SetFAnimPosition(const AValue: cardinal);
155begin
156 if FAnimPosition = AValue then
157 Exit;
158 if (AValue < 1) or (AValue > FSpriteCount) then
159 FAnimPosition := 1
160 else
161 FAnimPosition := AValue;
162
163 if Assigned(FOnPositionChanged) then
164 FOnPositionChanged(Self);
165
166 if csDesigning in ComponentState then
167 Invalidate;
168end;
169
170procedure TBGRASpriteAnimation.SetFAnimRepeat(const AValue: cardinal);
171begin
172 if FAnimRepeat = AValue then
173 Exit;
174 FAnimRepeat := AValue;
175end;
176
177procedure TBGRASpriteAnimation.SetFAnimRepeatLap(const AValue: cardinal);
178begin
179 if (FAnimRepeatLap = AValue) then
180 Exit;
181 FAnimRepeatLap := AValue;
182
183 if (AValue = FAnimRepeat) and (AValue <> 0) then
184 begin
185 if csDesigning in ComponentState then
186 Exit;
187 SetFAnimStatic(True);
188 end;
189
190 if Assigned(FOnLapChanged) then
191 FOnLapChanged(Self);
192end;
193
194procedure TBGRASpriteAnimation.SetFAnimSpeed(const AValue: cardinal);
195begin
196 if FAnimSpeed = AValue then
197 Exit;
198 FAnimSpeed := AValue;
199 FAnimTimer.Interval := AValue;
200end;
201
202procedure TBGRASpriteAnimation.SetFAnimStatic(const AValue: boolean);
203begin
204 if FAnimStatic = AValue then
205 Exit;
206 FAnimStatic := AValue;
207
208 if csDesigning in ComponentState then
209 Exit;
210 FAnimTimer.Enabled := not AValue;
211end;
212
213{ Sprite Variables }
214
215procedure TBGRASpriteAnimation.SetFSprite(const AValue: TBitmap);
216begin
217 if (FSprite = AValue) or (AValue = nil) then
218 Exit;
219
220 FSprite := AValue;
221
222 Invalidate;
223end;
224
225procedure TBGRASpriteAnimation.SetFSpriteCount(const AValue: cardinal);
226begin
227 if (FSpriteCount = AValue) or (FSprite = nil) then
228 Exit;
229
230 if (AValue < 1) or (AValue > cardinal(FSprite.Width)) then
231 FSpriteCount := 1
232 else
233 FSpriteCount := AValue;
234
235 if AnimPosition > AValue then
236 SetFAnimPosition(1);
237
238 Invalidate;
239end;
240
241procedure TBGRASpriteAnimation.SetFSpriteFillOpacity(const AValue: byte);
242begin
243 if FSpriteFillOpacity = AValue then
244 Exit;
245 FSpriteFillOpacity := AValue;
246
247 if csDesigning in ComponentState then
248 Invalidate;
249end;
250
251procedure TBGRASpriteAnimation.SetFSpriteFlipMode(const AValue: TFlipMode);
252begin
253 if FSpriteFlipMode = AValue then
254 Exit;
255 FSpriteFlipMode := AValue;
256
257 if csDesigning in ComponentState then
258 Invalidate;
259end;
260
261procedure TBGRASpriteAnimation.SetFSpriteKeyColor(const AValue: TColor);
262begin
263 if FSpriteKeyColor = AValue then
264 Exit;
265 FSpriteKeyColor := AValue;
266
267 if csDesigning in ComponentState then
268 Invalidate;
269end;
270
271procedure TBGRASpriteAnimation.SetFSpriteResampleFilter(const AValue: TResampleFilter);
272begin
273 if FSpriteResampleFilter = AValue then
274 Exit;
275 FSpriteResampleFilter := AValue;
276
277 if csDesigning in ComponentState then
278 Invalidate;
279end;
280
281procedure TBGRASpriteAnimation.SetFSpriteResampleMode(const AValue: TResampleMode);
282begin
283 if FSpriteResampleMode = AValue then
284 Exit;
285 FSpriteResampleMode := AValue;
286
287 if csDesigning in ComponentState then
288 Invalidate;
289end;
290
291procedure TBGRASpriteAnimation.SetFSpriteRotation(const AValue: TRotationMode);
292begin
293 if FSpriteRotation = AValue then
294 Exit;
295 FSpriteRotation := AValue;
296
297 if csDesigning in ComponentState then
298 Invalidate;
299end;
300
301{ General Variables }
302
303procedure TBGRASPriteAnimation.SetFAutoSize(const AValue: boolean);
304begin
305 if FAutoSize = AValue then
306 Exit;
307 FAutoSize := AValue;
308
309 if csDesigning in ComponentState then
310 Invalidate;
311end;
312
313procedure TBGRASpriteAnimation.SetFCenter(const AValue: boolean);
314begin
315 if FCenter = AValue then
316 Exit;
317 FCenter := AValue;
318
319 if csDesigning in ComponentState then
320 Invalidate;
321end;
322
323procedure TBGRASpriteAnimation.SetFProportional(const AValue: boolean);
324begin
325 if FProportional = AValue then
326 Exit;
327 FProportional := AValue;
328
329 if csDesigning in ComponentState then
330 Invalidate;
331end;
332
333procedure TBGRASpriteAnimation.SetFStretch(const AValue: boolean);
334begin
335 if FStretch = AValue then
336 Exit;
337 FStretch := AValue;
338
339 if csDesigning in ComponentState then
340 Invalidate;
341end;
342
343procedure TBGRASpriteAnimation.SetFTile(const AValue: boolean);
344begin
345 if FTile = AValue then
346 Exit;
347 FTile := AValue;
348
349 if csDesigning in ComponentState then
350 Invalidate;
351end;
352
353{ Utils }
354
355function TBGRASpriteAnimation.DoCalculateDestRect(AWidth, AHeight: integer): TRect;
356var
357 PicWidth: integer;
358 PicHeight: integer;
359 ImgWidth: integer;
360 ImgHeight: integer;
361 w: integer;
362 h: integer;
363begin
364 PicWidth := AWidth;
365 PicHeight := AHeight;
366 ImgWidth := ClientWidth;
367 ImgHeight := ClientHeight;
368 if Stretch or (Proportional and ((PicWidth > ImgWidth) or
369 (PicHeight > ImgHeight))) then
370 begin
371 if Proportional and (PicWidth > 0) and (PicHeight > 0) then
372 begin
373 w := ImgWidth;
374 h := (PicHeight * w) div PicWidth;
375 if h > ImgHeight then
376 begin
377 h := ImgHeight;
378 w := (PicWidth * h) div PicHeight;
379 end;
380 PicWidth := w;
381 PicHeight := h;
382 end
383 else
384 begin
385 PicWidth := ImgWidth;
386 PicHeight := ImgHeight;
387 end;
388 end;
389
390 Result := Rect(0, 0, PicWidth, PicHeight);
391
392 if Center then
393 OffsetRect(Result, (ImgWidth - PicWidth) div 2, (ImgHeight - PicHeight) div 2);
394end;
395
396function TBGRASpriteAnimation.DoCalculatePosition(AValue: integer): integer;
397begin
398 if FAnimInvert then
399 Result := -AValue * (FSpriteCount - FAnimPosition)
400 else
401 Result := -AValue * (FAnimPosition - 1);
402end;
403
404function TBGRASpriteAnimation.DoCalculateSize(AValue: cardinal): cardinal;
405begin
406 Result := trunc(AValue div FSpriteCount);
407end;
408
409procedure TBGRASpriteAnimation.DoSpriteResampleFilter(ABitmap: TBGRABitmap);
410begin
411 ABitmap.ResampleFilter := FSpriteResampleFilter;
412end;
413
414procedure TBGRASpriteAnimation.DoSpriteFillOpacity(ABitmap: TBGRABitmap);
415begin
416 if FSpriteFillOpacity <> 255 then
417 ABitmap.ApplyGlobalOpacity(FSpriteFillOpacity);
418end;
419
420procedure TBGRASpriteAnimation.DoSpriteFlip(ABitmap: TBGRABitmap);
421begin
422 case FSpriteFlipMode of
423 flNone: Exit;
424 flHorizontal: ABitmap.HorizontalFlip;
425 flVertical: ABitmap.VerticalFlip;
426 flBoth:
427 begin
428 ABitmap.HorizontalFlip;
429 ABitmap.VerticalFlip;
430 end;
431 end;
432end;
433
434procedure TBGRASpriteAnimation.DoSpriteKeyColor(ABitmap: TBGRABitmap);
435begin
436 if FSpriteKeyColor <> clNone then
437 ABitmap.ReplaceColor(ColorToBGRA(ColorToRGB(FSpriteKeyColor), 255),
438 BGRAPixelTransparent);
439end;
440
441{ Main }
442
443procedure TBGRASpriteAnimation.Paint;
444
445 procedure DrawFrame;
446 begin
447 with inherited Canvas do
448 begin
449 Pen.Color := clBlack;
450 Pen.Style := psDash;
451 MoveTo(0, 0);
452 LineTo(Self.Width - 1, 0);
453 LineTo(Self.Width - 1, Self.Height - 1);
454 LineTo(0, Self.Height - 1);
455 LineTo(0, 0);
456 end;
457 end;
458
459var
460 TempSprite, TempSpriteBGRA: TBGRABitmap;
461 TempSpriteWidth, TempSpriteHeight, TempSpritePosition: integer;
462begin
463 if csDesigning in ComponentState then
464 DrawFrame;
465
466 if FSprite = nil then
467 Exit;
468
469 if (Width > 0) and (Height > 0) then
470 begin
471 TempSpriteWidth := DoCalculateSize(FSprite.Width);
472 TempSpriteHeight := FSprite.Height;
473 TempSpritePosition := DoCalculatePosition(TempSpriteWidth);
474
475 TempSpriteBGRA := TBGRABitmap.Create(FSprite);
476 TempSprite := TBGRABitmap.Create(TempSpriteWidth, TempSpriteHeight);
477 TempSprite.PutImage(TempSpritePosition, 0, TempSpriteBGRA, dmDrawWithTransparency);
478 TempSpriteBGRA.Free;
479
480 if Assigned(FOnRedrawBefore) then
481 FOnRedrawBefore(Self, TempSprite);
482
483 DoSpriteDraw(TempSprite);
484 end;
485end;
486
487function TBGRASpriteAnimation.AnimatedGifToSprite(Filename: string): TBGRABitmap;
488var
489 TempGif: TBGRAAnimatedGif;
490 TempBitmap: TBGRABitmap;
491 n: integer;
492begin
493 TempGif := TBGRAAnimatedGif.Create(Filename);
494 TempBitmap := TBGRABitmap.Create(TempGif.Width * TempGif.Count, TempGif.Height);
495
496 for n := 0 to TempGif.Count do
497 begin
498 TempGif.CurrentImage := n;
499 TempBitmap.PutImage(TempGif.Width * n, 0, TempGif.MemBitmap, dmSet);
500 end;
501 TempGif.Free;
502
503 Result := TempBitmap;
504end;
505
506procedure TBGRASpriteAnimation.DoSpriteDraw(ABitmap: TBGRABitmap);
507var
508 TempRect: TRect;
509begin
510 DoSpriteResampleFilter(ABitmap);
511 DoSpriteKeyColor(ABitmap);
512 DoSpriteFillOpacity(ABitmap);
513 DoSpriteFlip(ABitmap);
514
515 case FSpriteRotation of
516 rtClockWise: BGRAReplace(ABitmap, ABitmap.RotateCW);
517 rtCounterClockWise: BGRAReplace(ABitmap, ABitmap.RotateCCW);
518 end;
519
520 { TODO -oLainz : If there is no Sprite loaded and you set 'Tile' to true a division by cero error is shown }
521 if Tile then
522 BGRAReplace(ABitmap, ABitmap.GetPart(rect(0, 0, Width, Height)));
523
524 TempRect := DoCalculateDestRect(ABitmap.Width, ABitmap.Height);
525
526 if Assigned(FOnRedrawAfter) then
527 FOnRedrawAfter(Self, ABitmap);
528
529 if Stretch and (FSpriteResampleMode = rmFineResample) then
530 BGRAReplace(ABitmap, ABitmap.Resample(Width, Height, FSpriteResampleMode));
531
532 ABitmap.Draw(Canvas, TempRect, False);
533 ABitmap.Free;
534end;
535
536procedure TBGRASpriteAnimation.DoAnimTimerOnTimer(Sender: TObject);
537begin
538 Invalidate;
539
540 if Assigned(FOnPositionChanging) then
541 FOnPositionChanging(Self);
542 SetFAnimPosition(FAnimPosition + 1);
543
544 if FAnimPosition = FSpriteCount then
545 begin
546 if Assigned(FOnLapChanging) then
547 FOnLapChanging(Self);
548 SetFAnimRepeatLap(FAnimRepeatLap + 1);
549 end;
550end;
551
552{ Create / Destroy }
553
554constructor TBGRASpriteAnimation.Create(AOwner: TComponent);
555begin
556 inherited Create(AOwner);
557 with GetControlClassDefaultSize do
558 SetInitialBounds(0, 0, CX, CY);
559 FAnimInvert := False;
560 FAnimPosition := 1;
561 FAnimRepeat := 0;
562 FAnimRepeatLap := 0;
563 FAnimSpeed := 1000;
564 FAnimStatic := False;
565 FAnimTimer := TTimer.Create(Self);
566 FAnimTimer.Interval := FAnimSpeed;
567 FAnimTimer.OnTimer := @DoAnimTimerOnTimer;
568 FAutoSize := False;
569 FCenter := True;
570 FProportional := True;
571 FStretch := True;
572 FSprite := TBitmap.Create;
573 FSpriteCount := 1;
574 FSpriteFillOpacity := 255;
575 FSpriteFlipMode := flNone;
576 FSpriteKeyColor := clNone;
577 FSpriteResampleFilter := rfLinear;
578 FSpriteResampleMode := rmSimpleStretch;
579 FSpriteRotation := rtNone;
580 FTile := False;
581
582 if csDesigning in ComponentState then
583 FAnimTimer.Enabled := False;
584end;
585
586destructor TBGRASpriteAnimation.Destroy;
587begin
588 FAnimTimer.OnTimer := nil;
589 FAnimTimer.Free;
590 FSprite.Free;
591 inherited Destroy;
592end;
593
594end.
Note: See TracBrowser for help on using the repository browser.