gifanimator.pas

可以用来显示 Gif 的VCL控件 完整源码版本

function TGifAnimator.GetFrameBitmap(Index: Integer;
  var TransColor: TColor): TBitmap;
var
  I, Last, First: Integer;
  SavePal: HPalette;
  UseCache: Boolean;
begin
  Index := Min(Index, FImage.Count - 1);
  UseCache := (FCache <> nil) and (FCacheIndex = Index - 1) and (FCacheIndex >= 0) and
    (FImage.Frames[FCacheIndex].DisposalMethod <> dmRestorePrevious);
  if UseCache then begin
    Result := FCache;
    TransColor := FTransColor;
  end
  else begin
    FCache.Free;
    FCache := nil;
    Result := TBitmap.Create;
  end;
  try
    with Result do begin
      if not UseCache then begin
        Width := FImage.ScreenWidth;
        Height := FImage.ScreenHeight;
      end;
      Last := Index;
      First := Max(0, Last);
      SavePal := 0;
      if FImage.Palette <> 0 then begin
        SavePal := SelectPalette(Canvas.Handle, FImage.Palette, False);
        RealizePalette(Canvas.Handle);
      end;
      if not UseCache then begin
        if (FImage.Frames[FImage.FrameIndex].TransparentColor <> clNone) then
        begin
          TransColor := GetNearestColor(Canvas.Handle,
            ColorToRGB(FImage.Frames[FImage.FrameIndex].TransparentColor));
          Canvas.Brush.Color := PaletteColor(TransColor);
        end
        else if (FImage.BackgroundColor <> clNone) and FImage.Transparent then
          Canvas.Brush.Color := PaletteColor(FImage.BackgroundColor)
        else Canvas.Brush.Color := PaletteColor(clWindow);
        Canvas.FillRect(Bounds(0, 0, Width, Height));
        while First > 0 do begin
          if (FImage.ScreenWidth = FImage.Frames[First].Width) and
            (FImage.ScreenHeight = FImage.Frames[First].Height) then
          begin
            if (FImage.Frames[First].TransparentColor = clNone) or
              ((FImage.Frames[First].DisposalMethod = dmRestoreBackground) and
              (First < Last)) then Break;
          end;
          Dec(First);
        end;
        for I := First to Last - 1 do begin
          with FImage.Frames[I] do
            case DisposalMethod of
              dmUndefined, dmLeave:
                Draw(Canvas, Bounds(Origin.X, Origin.Y, Width, Height), True);
              dmRestoreBackground:
                if I > First then
                  Canvas.FillRect(Bounds(Origin.X, Origin.Y, Width, Height));
              dmRestorePrevious:
                begin { do nothing } end;
            end;
        end;
      end
      else begin
        with FImage.Frames[FCacheIndex] do
          if DisposalMethod = dmRestoreBackground then
            Canvas.FillRect(Bounds(Origin.X, Origin.Y, Width, Height));
      end; { UseCache }
      with FImage.Frames[Last] do
        Draw(Canvas, Bounds(Origin.X, Origin.Y, Width, Height), True);
      if FImage.Palette <> 0 then
        SelectPalette(Canvas.Handle, SavePal, False);
    end;
    FCache := Result;
    FCacheIndex := Index;
    FTransColor := TransColor;
  except
    if not UseCache then Result.Free;
    raise;
  end;
end;

function TGifAnimator.GetPalette: HPALETTE;
begin
  Result := 0;
  if not FImage.Empty then Result := FImage.Palette;
end;

procedure TGifAnimator.ImageChanged(Sender: TObject);
begin
  Lock;
  try
    FCacheIndex := -1;
    FCache.Free;
    FCache := nil;
    FTransColor := clNone;
    FFrameIndex := FImage.FrameIndex;
    if (FFrameIndex >= 0) and (FImage.Count > 0) then
      FTimer.Interval := GetDelayTime(FFrameIndex);
  finally
    Unlock;
  end;
  PictureChanged;
  Change;
end;

procedure TGifAnimator.SetImage(Value: TGIF_Image);
begin
  Lock;
  try
    FImage.Assign(Value);
  finally
    Unlock;
  end;
end;

procedure TGifAnimator.SetCenter(Value: Boolean);
begin
  if Value <> FCenter then begin
    Lock;
    try
      FCenter := Value;
    finally
      Unlock;
    end;
    PictureChanged;
    if Animate then Repaint;
  end;
end;

procedure TGifAnimator.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then begin
    Lock;
    try
      FStretch := Value;
    finally
      Unlock;
    end;
    PictureChanged;
    if Animate then Repaint;
  end;
end;

procedure TGifAnimator.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then begin
    Lock;
    try
      FTransparent := Value;
    finally
      Unlock;
    end;
    PictureChanged;
    if Animate then Repaint;
  end;
end;

procedure TGifAnimator.SetFrameIndex(Value: Integer);
begin
  if Value <> FFrameIndex then begin
    if (Value < FImage.Count) and (Value >= 0) then begin
      Lock;
      try
        FFrameIndex := Value;
        if (FFrameIndex >= 0) and (FImage.Count > 0) then
          FTimer.Interval := GetDelayTime(FFrameIndex);
      finally
        Unlock;
      end;
      FrameChanged;
      PictureChanged;
    end;
  end;
end;

procedure TGifAnimator.DoPaintImage;
var
  Frame: TBitmap;
  Dest: TRect;
  TransColor: TColor;
begin
  { copy image from parent and back-level controls }
  if FImage.Transparent or FImage.Empty then
    CopyParentImage(Self, Canvas);
  if (not FImage.Empty) and (FImage.ScreenWidth > 0) and
    (FImage.ScreenHeight> 0) then
  begin
    TransColor := clNone;
    Frame := GetFrameBitmap(FrameIndex, TransColor);
    if Stretch then Dest := ClientRect
    else if Center then
      Dest := Bounds((ClientWidth - Frame.Width) div 2,
        (ClientHeight - Frame.Height) div 2, Frame.Width, Frame.Height)
    else
      Dest := Rect(0, 0, Frame.Width, Frame.Height);
    if (TransColor = clNone) or not FTransparent then
      Canvas.StretchDraw(Dest, Frame)
    else begin
      StretchBitmapRectTransparent(Canvas, Dest.Left, Dest.Top,
        WidthOf(Dest), HeightOf(Dest), Bounds(0, 0, Frame.Width,
        Frame.Height), Frame, TransColor);
    end;
  end;
end;

procedure TGifAnimator.Paint;
begin
  PaintImage;
  if FImage.Transparent or FImage.Empty then
    PaintDesignRect;
end;

procedure TGifAnimator.TimerDeactivate;
var
  F: TCustomForm;
begin
  SetAnimate(False);
  if (csDesigning in ComponentState) then begin
    F := GetParentForm(Self);
    if (F <> nil) and (F.Designer <> nil) then
      F.Designer.Modified;
  end;
end;

procedure TGifAnimator.TimerExpired(Sender: TObject);
begin
  if Visible and (FImage.Count > 1) and (Parent <> nil) and
    Parent.HandleAllocated then
  begin
    Lock;
    try
      if FFrameIndex < FImage.Count - 1 then Inc(FFrameIndex)
      else FFrameIndex := 0;
      FTimerRepaint := True;
      try
        FrameChanged;
        Repaint;
      finally
        FTimerRepaint := False;
        if (FFrameIndex >= 0) and (FFrameIndex < FImage.Count) then
          FTimer.Interval := GetDelayTime(FFrameIndex);
      end;
      if not FLoop and (FFrameIndex = 0) then TimerDeactivate;
    finally
      Unlock;
    end;
  end;
end;

procedure TGifAnimator.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGifAnimator.FrameChanged;
begin
  if Assigned(FOnFrameChanged) then FOnFrameChanged(Self);
end;

procedure TGifAnimator.Stop;
begin
  if Assigned(FOnStop) then FOnStop(Self);
end;

procedure TGifAnimator.Start;
begin
  if Assigned(FOnStart) then FOnStart(Self);
end;

procedure TGifAnimator.SetAutoSize(Value: Boolean);
begin
  if Value <> FAutoSize then begin
    FAutoSize := Value;
    PictureChanged;
  end;
end;

procedure TGifAnimator.SetAnimate(Value: Boolean);
begin
  if FAnimate <> Value then begin
    if Value then begin
      FTimer.OnTimer := TimerExpired;
      FTimer.Enabled := True;
      FAnimate := FTimer.Enabled;
      Start;
    end
    else begin
      FTimer.Enabled := False;
      FTimer.OnTimer := nil;
      FAnimate := False;
      Stop;
      PictureChanged;
    end;
  end;
end;

procedure TGifAnimator.WMSize(var Message: TWMSize);
begin
  inherited;
  AdjustSize;
end;

procedure Register;
begin
  RegisterComponents('MyRxLib', [TGifAnimator]);
end;

end.