if not CanAnimate then Exit; P := FDelays; for I :=0 to FrameCount -1do begin P^ :=100; Inc(P); end; end; procedure TImageAnimatBase.SetDelays(ADelays: array of LongWord); var I, Count: Integer; P: PLongWord; begin if not CanAnimate then Exit; Count := Length(ADelays); if Count =0 then begin SetDefaultDelays; Exit; end; P := FDelays; for I :=0 to FrameCount -1do begin if I < Count then P^ := ADelays[I] else P^ := ADelays[Count -1]; Inc(P); end; end; procedure TImageAnimatBase.SetFrameCount(const Count: Integer); begin if FFrameCount <> Count then begin if Assigned(FDelays) then begin FreeMem(FDelays); FDelays := nil; end; FFrameCount := Count; if FFrameCount >1 then GetMem(FDelays, FFrameCount * Sizeof(LongWord)); end; end; procedure TImageAnimatBase.SetLoopCount(const Value: Integer); begin if FLoopCount <> Value then if Value <0 then FLoopCount := GetDefaultLoopCount else FLoopCount := Value; end; procedure TImageAnimatBase.SetPlay(const Value: Boolean); begin if (Play <> Value) and (not Value or CanAnimate) then begin if Value then begin FFrameIndex :=0; FLoopIndex :=0; end; FTimer.Enabled := Value; end; end; procedure TImageAnimatBase.TimerOnTimer(Sender: TObject); var P: PLongWord; begin P := FDelays; Inc(P, FrameIndex); if P^<> FTimer.Interval then FTimer.Interval := P^; DoUpdateFrames; if (FLoopCount <>0) and (FLoopIndex = LoopCount) then Play := False; end; procedure TImageAnimatBase.UpdateFrames; begin if CanAnimate then DoUpdateFrames; end; end.
下面是基于GDI+的TImageAnimatBase派生类TGpImageAnimator源码:
unit GpImageAnimate; interface uses SysUtils, ActiveX, Gdiplus, ImageAnimateBase; type TGpImageAnimator =class(TImageAnimatBase) private FImage: TGpImage; FGUID: TGUID; FDimensionTime: Boolean; procedure SetFrameDimensionInfo; procedure SetImage(const Value: TGpImage); protected procedure DoUpdateFrames; override; function GetDefaultLoopCount: Integer; override; procedure SetDefaultDelays; override; public property Image: TGpImage read FImage write SetImage; end; implementation uses GdipTypes; ...{ TGpImageAnimator } procedure TGpImageAnimator.DoUpdateFrames; begin Image.SelectActiveFrame(FGUID, FrameIndex); inherited; end; function TGpImageAnimator.GetDefaultLoopCount: Integer; var Size: Integer; Item: PPropertyItem; begin if not FDimensionTime then begin Result := inherited GetDefaultLoopCount; Exit; end; Size := Image.GetPropertyItemSize(PropertyTagLoopCount); GetMem(Item, Size); try Image.GetPropertyItem(PropertyTagLoopCount, Item); Result := Word(Item^.value^); finally FreeMem(Item, Size); end; end; procedure TGpImageAnimator.SetDefaultDelays; var Size: Integer; Item: PPropertyItem; I: Integer; P, Q: PLongWord; begin if not FDimensionTime then begin inherited; Exit; end; Size := Image.GetPropertyItemSize(PropertyTagFrameDelay); GetMem(Item, Size); try Image.GetPropertyItem(PropertyTagFrameDelay, Item); P := Delays; Q := PLongWord(Item^.value); for I :=0 to FrameCount -1do begin P^ := Q^*10; Inc(P); Inc(Q); end; finally FreeMem(Item, Size); end; end; procedure TGpImageAnimator.SetFrameDimensionInfo; var Guids: array of TGUID; I, Count: Integer; begin Count := Image.FrameDimensionsCount; SetLength(Guids, Count); Image.GetFrameDimensionsList(@Guids[0], Count); I :=0; while (I < Count) and (GUIDToString(Guids[I]) <> GUIDToString(FrameDimensionTime)) and (GUIDToString(Guids[I]) <> GUIDToString(FrameDimensionPage)) do Inc(I); if I = Count then raise Exception.Create('Image does not contain Time or Page Frame Dimensions.'); FGUID := Guids[I]; FDimensionTime := GUIDToString(FGUID) = GUIDToString(FrameDimensionTime); SetFrameCount(Image.GetFrameCount(FGUID)); SetDefaultDelays; LoopCount :=-1; end; procedure TGpImageAnimator.SetImage(const Value: TGpImage); begin if (FImage <> Value) and not Play then begin FImage := Value; if Assigned(FImage) then SetFrameDimensionInfo else begin FDimensionTime := False; SetFrameCount(0); end; end; end; end.