teeffect.pas

这个东西的功能很强大

        DstRect := Rect(0, 0, MatrixWidth * Animation.Resolution, MatrixHeight * Animation.Resolution);
        OffsetRect(DstRect, i * RectWidth(DstRect), j * RectHeight(DstRect));

        StretchAlphaRect(DestImage.Bits^, DestImage.Width, DestImage.Height,
          DstRect.Left, DstRect.Top, RectWidth(DstRect), RectHeight(DstRect),
          0, 0, MatrixWidth, MatrixHeight, MatrixFade^);
      end;

    { Clear alpha }
    ClearAlphaFunc(DestImage.Bits, DestImage.Width * DestImage.Height, teTransparent);

    { Blending }
    DestImage.AlphaBlend := true;
    DestImage.Draw(ResultImage, 0, 0);
  end;
end;

procedure CalcFrameManual(AMultiRec: TteMultiAniRec;
  Percent: byte);
begin
  { Manual Animation }
  with AMultiRec do
  begin
    { Clear alpha }
    ClearAlphaFunc(DestImage.Bits, DestImage.Width * DestImage.Height, teTransparent);
    { Calc frame }
    TteProcManual(ProcItem.Proc)(ResultImage, DestImage, Animation, Percent);
  end;
end;

var
  MultiAniArray: array [0..MaxAni] of TteMultiAniRec;

function ReserveIndex: integer;
var
  i: integer;
begin
  for i := Low(MultiAniArray) to High(MultiAniArray) do
    if (not MultiAniArray[i].Animating) and (not MultiAniArray[i].Reserved) then
    begin
      MultiAniArray[i].Reserved := true;
      Result := i;
      Exit;
    end;
  Result := -1;
end;

procedure ReleaseReserved(AIndex: integer);
begin
  MultiAniArray[AIndex].Reserved := false;
end;

function FindIndex: integer;
var
  i: integer;
begin
  for i := Low(MultiAniArray) to High(MultiAniArray) do
    if (not MultiAniArray[i].Animating) and (not MultiAniArray[i].Reserved) then
    begin
      Result := i;
      Exit;
    end;
  Result := -1;
end;

function TimerEnabled: boolean;
var
  i: integer;
begin
  for i := Low(MultiAniArray) to High(MultiAniArray) do
    if MultiAniArray[i].Animating then
    begin
      Result := true;
      Exit;
    end;
  Result := false;
end;

function StartMultiAnimation(ACanvas: TCanvas; AX, AY: integer; ASourceImage, ADestImage: TteBitmap;
  AAnimation: TteAnimationRec; AIndex: integer = -1): integer;
var
  MaskBitmap: TBitmap;
  Mask: TteBitmap;
  i, j: integer;
begin
  if AIndex = -1 then
    Result := FindIndex
  else
    Result := AIndex;
  if Result = -1 then Exit;

  with MultiAniArray[Result] do
  begin
    SourceImage := ASourceImage;
    DestImage := ADestImage;
    Animation := AAnimation;

    if SourceImage = nil then Exit;
    if SourceImage.Width * SourceImage.Height = 0 then Exit;

    { Check }
    if DestImage = nil then Exit;
    if DestImage.Width * DestImage.Height = 0 then Exit;

    { Select Animation }
    if Animation.Effect = SRandomSelection then
      ProcItem := ProcList[TteProcItem(ProcList.Items[Random(ProcList.Count)]).Name]
    else
      ProcItem := ProcList[Animation.Effect];

    if Animation.Effect <> SBitmap then
      if (ProcItem = nil) or (@ProcItem.Proc = nil) then Exit;

    ResultImage := TteBitmap.Create;
    ResultImage.SetSize(SourceImage.Width, SourceImage.Height);

    { Calc size an len Matrix }
    MatrixWidth := SourceImage.Width div Animation.Resolution div Animation.TileCount + 1;
    MatrixHeight := SourceImage.Height div Animation.Resolution div Animation.TileCount + 1;

    { Create matrix }
    if Animation.Effect <> SBitmap then
      case ProcItem.Kind of
        pkFade:
          begin
            MatrixLen := MatrixWidth * MatrixHeight;
            GetMem(MatrixFade, MatrixLen);
            { Create copy for rotatation }
            if Animation.Rotation <> krNone then GetMem(CopyMatrixFade, MatrixLen);
          end;
        pkSlide:
          begin
            MatrixLen := MatrixWidth * MatrixHeight * SizeOf(TtePointSlide);
            GetMem(MatrixSlide, MatrixLen);
          end;
      end
    else
    begin
      { Bitmap Ani }
      MatrixLen := MatrixWidth * MatrixHeight;
      GetMem(MatrixFade, MatrixLen);
      GetMem(CopyMatrixFade, MatrixLen);

      { Copy from bitmap }
      MaskBitmap := TBitmap.Create;
      if Animation.Rotation in [krRotate90, krRotate270] then
      begin
        MaskBitmap.Width := MatrixHeight;
        MaskBitmap.Height := MatrixWidth;
        MaskBitmap.Canvas.StretchDraw(Rect(0, 0, MatrixHeight, MatrixWidth), Animation.Bitmap)
      end
      else
      begin
        MaskBitmap.Width := MatrixWidth;
        MaskBitmap.Height := MatrixHeight;
        MaskBitmap.Canvas.StretchDraw(Rect(0, 0, MatrixWidth, MatrixHeight), Animation.Bitmap);
      end;

      Mask := TteBitmap.Create;
      Mask.Assign(MaskBitmap);

      for i := 0 to MatrixWidth - 1 do
        for j := 0 to MatrixHeight - 1 do
        begin
          MatrixFade^[i + j * MatrixWidth] := Mask.Bits[i + j * MatrixWidth] and not $FFFFFF00;
          CopyMatrixFade^[i + j * MatrixWidth] := Mask.Bits[i + j * MatrixWidth] and not $FFFFFF00;
        end;

      Mask.Free;
      MaskBitmap.Free;
    end;

    CurTime := 0.01;
    Animating := true;
    Drawing := false;
    Canvas := ACanvas;
    X := AX;
    Y := AY;

    MultiTimer.Enabled := TimerEnabled;
  end;
end;

procedure StopMultiAnimation(AIndex: integer; DrawLastFrame: boolean = false);
begin
  if AIndex = -1 then Exit;

  with MultiAniArray[AIndex] do
  begin
    if (DestImage = nil) or (SourceImage = nil) or (ResultImage = nil) then Exit;
    if not Animating then Exit;

    {$IFDEF KS_COMPILER6_UP}
    if Canvas.HandleAllocated and DrawLastFrame then
    {$ELSE}
    if DrawLastFrame then
    {$ENDIF}
    begin
      { Calc last frame }
      DestImage.AlphaBlend := true;
      DestImage.Draw(ResultImage, 0, 0);
      { Draw dest image }
      ResultImage.Draw(Canvas, X, Y);
    end;

    { Free matrix }
    if Animation.Effect <> SBitmap then
      case ProcItem.Kind of
        pkFade:
          begin
            if Animation.Rotation <> krNone then FreeMem(CopyMatrixFade, MatrixLen);
            FreeMem(MatrixFade, MatrixLen);
          end;
        pkSlide:
          begin
            FreeMem(MatrixSlide, MatrixLen);
          end;
      end
    else
    begin
      { Bitmap Ani }
      FreeMem(CopyMatrixFade, MatrixLen);
      FreeMem(MatrixFade, MatrixLen);
    end;

    { Free image }
    ResultImage.Free;

    Animating := false;
    MultiTimer.Enabled := TimerEnabled;
  end;
end;

procedure DrawMultiAnimation(AIndex: integer);
var
  Percent: integer;
begin
  { Calc animation frame }
  with MultiAniArray[AIndex] do
  begin
    if (DestImage = nil) or (SourceImage = nil) or (ResultImage = nil) then Exit;
    if not Animating then Exit;
    CurTime := CurTime + TimerInterval;

    if Drawing then Exit;
    Drawing := true;
    try
      Percent := Round((CurTime / Animation.Time) * 100);
      if Percent >= 100 then Percent := 100;

      { Copy source to result }
      SourceImage.Draw(ResultImage, 0, 0);

      if Animation.Effect <> SBitmap then
        case ProcItem.Kind of
          pkFade:
            begin
              { Fade animation }
              CalcFrameFade(MultiAniArray[AIndex], Percent);
            end;
          pkSlide:
            begin
              { Slide animation }
              CalcFrameSlide(MultiAniArray[AIndex], Percent);
            end;
          pkManual:
            begin
              { Manual animation }
              CalcFrameManual(MultiAniArray[AIndex], Percent);
            end;
        end
      else
      begin
        { Bitmap animation }
        CalcFrameBitmap(MultiAniArray[AIndex], Percent);
      end;

      ResultImage.Draw(Canvas, X, Y);

      if Percent >= 100 then
      begin
        StopMultiAnimation(AIndex);
        Exit;
      end;
    finally
      Drawing := false;
    end;
  end;
end;

function IsAnimating(AIndex: integer): boolean;
begin
  Result := (AIndex >= 0) and MultiAniArray[AIndex].Animating;
end;

procedure ExecuteAnimation(ACanvas: TCanvas; AX, AY: integer; ASourceImage, ADestImage: TteBitmap; AAnimation: TteAnimationRec);
var
  Index: integer;
begin
  Index := StartMultiAnimation(ACanvas, AX, AY, ASourceImage, ADestImage, AAnimation);
  while IsAnimating(Index) do
    Application.ProcessMessages;
end;

{$IFDEF KS_STATICEFFECTTIMER }

constructor TteMultiObject.Create;
begin
  inherited;
  T := TteTimer.Create;
end;

destructor TteMultiObject.Destroy;
begin
  T.Free;
  inherited;
end;

{$ENDIF}

procedure TteMultiObject.DoMultiTimer(Sender: TObject);
var
  i: integer;
  {$IFNDEF KS_STATICEFFECTTIMER }
  T: TteTimer;
  {$ENDIF}
  Time: single;
begin
  {$IFNDEF KS_STATICEFFECTTIMER }
  T := TteTimer.Create;
  try
  {$ENDIF}
    StartTimer(T);

    for i := Low(MultiAniArray) to High(MultiAniArray) do
    begin
      DrawMultiAnimation(i);
    end;

    Time := StopTimer(T);
  {$IFNDEF KS_STATICEFFECTTIMER }
  finally
    T.Free;
  end;
  {$ENDIF}

  { Add time to all effects }
  for i := Low(MultiAniArray) to High(MultiAniArray) do
    MultiAniArray[i].CurTime := MultiAniArray[i].CurTime + Time;
end;

var
  MultiObject: TteMultiObject;





type

  PLongword = ^longword;

  PLongArray = ^TLongArray;
  TLongArray = array [0..0] of longword;

  PByteArray = ^TByteArray;
  TByteArray = array [0..0] of byte;
  
procedure StretchAlphaRect(var X; Width, Height, XDst, YDst, WDst, HDst,
  XSrc, YSrc, WSrc, HSrc: integer; var Alpha);
var
  C: PLongword;
  A, AP: PByte;
  CArray: PLongArray;
  AArray: PByteArray;

  R: TRect;
  SFX, SFY: integer;
  DstY, DstX, SrcX: integer;
  SX, SY: integer;
  DX, DY: integer;
  SrcRect, DstRect: TRect;
begin
  SrcRect := Rect(XSrc, YSrc, XSrc + WSrc, YSrc + HSrc);
  DstRect := Rect(XDst, YDst, XDst + WDst, YDst + HDst);

  IntersectRect(R, SrcRect, Rect(0, 0, Width, Height));
  if (RectWidth(R) <= 0) or (RectHeight(R) <= 0) then Exit;
  if (RectWidth(DstRect) <= 0) or (RectHeight(DstRect) <= 0) then Exit;
  IntersectRect(R, DstRect, Rect(0, 0, Width, Height));
  if (RectWidth(R) <= 0) or (RectHeight(R) <= 0) then Exit;

  SFX := MulDiv((R.Left - DstRect.Left) * WSrc, 65535, WDst);
  SFY := MulDiv((R.Top - DstRect.Top) * HSrc, 65535, HDst);

  DX := (WSrc shl 16) div WDst;
  DY := (HSrc shl 16) div HDst;
  SY := SFY;

  CArray := PLongArray(@X);
  AArray := PByteArray(@Alpha);

  for DstY := R.Top to R.Bottom - 1 do
  begin
    A := @AArray[SrcRect.Left + (SY shr 16 + SrcRect.Top) * RectWidth(SrcRect)];
    C := @CArray[R.Left + (DstY * Width)];
    SX := SFX;
    for DstX := R.Left to R.Right - 1 do
    begin
      SrcX := (SX shr 14 and $FFFFFFFC) shr 2;
      Inc(SX, DX);
      { Get alpha }
      AP := PByte(Integer(A) + SrcX);
      { Set Alpha }
      C^ := C^ and not AlphaMask;
      C^ := C^ or (AP^ shl 24);

      Inc(C);
    end;
    Inc(SY, DY);
  end;
end;



{$WARNINGS OFF}

procedure RegisterProc(AName: string; AKind: TteProcKind; AProc: TteProc);
var
  Item: TteProcItem;
  i: integer;
begin
  if ProcList = nil then
    ProcList := TteProcList.Create;

  for i := 0 to ProcList.Count - 1 do
  begin
    { Check by name }
    if TteProcItem(ProcList.Items[i]).Name = LowerCase(AName) then
      raise EProcItemError.CreateFmt(SProcListAlreadyExists, [AName]);
    { Check by proc }
    if @TteProcItem(ProcList.Items[i]).Proc = @AProc then
      raise EProcItemError.CreateFmt(SProcListAlreadyExists, [AName]);
  end;

  Item := TteProcItem.Create;
  case AKind of
    pkFade: Item.Name := SFade + AName;
    pkSlide: Item.Name := SSlide + AName;
    pkManual: Item.Name := SManual + AName;
  end;
  Item.Kind := AKind;
  Item.Proc := AProc;

  ProcList.Add(Item);
end;

{ TteProcList }

procedure TteProcList.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    TteProcItem(Items[i]).Free;

  inherited;
end;