gif_myrxgif.~pas

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

    try
      Ext.FExtType := etComment;
      if FExtensions = nil then FExtensions := TList.Create;
      FExtensions.Add(Ext);
    except
      Ext.Free;
      raise;
    end;
  end;
  if (Ext <> nil) then begin
    if (Ext.FData = nil) and ForceCreate then
      Ext.FData := TStringList.Create;
    Result := Ext.FData;
  end
  else Result := nil;
end;

function TGIF_Frame.GetComment: TStrings;
begin
  Result := FindComment(True);
end;

procedure TGIF_Frame.SetComment(Value: TStrings);
begin
  GetComment.Assign(Value);
end;

procedure TGIF_Frame.UpdateExtensions;
var
  Ext: TExtension;
  I: Integer;
begin
  Ext := FindExtension(FExtensions, etGraphic);
  if (FAnimateInterval > 0) or (FTransparentColor <> clNone) or
    (FDisposal <> dmUndefined) then
  begin
    if Ext = nil then begin
      Ext := TExtension.Create;
      Ext.FExtType := etGraphic;
      if FExtensions = nil then FExtensions := TList.Create;
      FExtensions.Add(Ext);
      with Ext.FExtRec.GCE do begin
        BlockSize := 4;
        PackedFields := 0;
        Terminator := 0;
      end;
    end;
  end;
  if Ext <> nil then
    with Ext.FExtRec.GCE do begin
      DelayTime := FAnimateInterval div 10;
      I := FindColorIndex(FImage.FColorMap, FTransparentColor);
      if I >= 0 then begin
        TransparentColorIndex := I;
        PackedFields := PackedFields or GCE_TRANSPARENT;
      end
      else PackedFields := PackedFields and not GCE_TRANSPARENT;
      PackedFields := (PackedFields and not GCE_DISPOSAL_METHOD) or
        (Ord(FDisposal) shl 2);
    end;
  if FExtensions <> nil then
    for I := FExtensions.Count - 1 downto 0 do begin
      Ext := TExtension(FExtensions[I]);
      if (Ext <> nil) and (Ext.FExtType = etComment) and
        ((Ext.FData = nil) or (Ext.FData.Count = 0)) then
      begin
        Ext.Free;
        FExtensions.Delete(I);
      end;
    end;
  if (FExtensions <> nil) and (FExtensions.Count > 0) then
    FOwner.FVersion := gv89a;
end;

procedure TGIF_Frame.EncodeBitmapStream(Stream: TMemoryStream);
var
  BI: PBitmapInfoHeader;
  ColorCount, W, H: Integer;
  Bits, Pal: Pointer;
begin
  ColorCount := 0;
  Stream.Position := 0;
  BI := PBitmapInfoHeader(Longint(Stream.Memory) + SizeOf(TBitmapFileHeader));
  W := BI^.biWidth; H := BI^.biHeight;
  Pal := PRGBPalette(Longint(BI) + SizeOf(TBitmapInfoHeader));
  Bits := Pointer(Longword(Stream.Memory) + PBitmapFileHeader(Stream.Memory)^.bfOffBits);
  case BI^.biBitCount of
    1: ColorCount := 2;
    4: ColorCount := 16;
    8: ColorCount := 256;
    else GifError(LoadStr(SGIFEncodeError));
  end;
  FInterlaced := False;
  FillColorTable(FImage.FColorMap, PRGBPalette(Pal)^, ColorCount);
  if FImage.FImageData = nil then FImage.FImageData := TMemoryStream.Create
  else FImage.FImageData.SetSize(0);
  try
    WriteGIFData(FImage.FImageData, BI^, FInterlaced, Bits, FOwner.DoProgress);
  except
    on EAbort do begin
      NewImage; { OnProgress can raise EAbort to cancel image save }
      raise;
    end
    else raise;
  end;
  FImage.FBitsPerPixel := 1;
  while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
    Inc(FImage.FBitsPerPixel);
  if FOwner.FImage.FColorMap.Count = 0 then begin
    FOwner.FImage.FColorMap := FImage.FColorMap;
    FOwner.FImage.FBitsPerPixel := FImage.FBitsPerPixel;
    FLocalColors := False;
  end
  else FLocalColors := True;
  FImage.FSize.X := W; FImage.FSize.Y := H;
  FOwner.FScreenWidth := Max(FOwner.FScreenWidth, FImage.FSize.X + FTopLeft.X);
  FOwner.FScreenHeight := Max(FOwner.FScreenHeight, FImage.FSize.Y + FTopLeft.Y);
end;

procedure TGIF_Frame.EncodeRasterData;
var
  Method: TMappingMethod;
  Mem: TMemoryStream;
begin
  if not Assigned(FBitmap) or FBitmap.Empty then GifError(LoadStr(SNoGIFData));
  if not (GetBitmapPixelFormat(FBitmap) in [pf1bit, pf4bit, pf8bit]) then
  begin
    if FGrayscale then Method := mmGrayscale
    else Method := DefaultMappingMethod;
    Mem := BitmapToMemoryStream(FBitmap, pf8bit, Method);
    if (Method = mmGrayscale) then FGrayscale := True;
  end
  else Mem := TMemoryStream.Create;
  try
    if Mem.Size = 0 then FBitmap.SaveToStream(Mem);
    EncodeBitmapStream(Mem);
  finally
    Mem.Free;
  end;
end;

procedure TGIF_Frame.WriteImageDescriptor(Stream: TStream);
var
  ImageDesc: TImageDescriptor;
begin
  with ImageDesc do begin
    PackedFields := 0;
    if FLocalColors then begin
      FImage.FBitsPerPixel := 1;
      while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do
        Inc(FImage.FBitsPerPixel);
      PackedFields := (PackedFields or ID_LOCAL_COLOR_TABLE) +
        (FImage.FBitsPerPixel - 1);
    end;
    if FInterlaced then PackedFields := PackedFields or ID_INTERLACED;
    ImageLeftPos := FTopLeft.X;
    ImageTopPos := FTopLeft.Y;
    ImageWidth := FImage.FSize.X;
    ImageHeight := FImage.FSize.Y;
  end;
  Stream.Write(ImageDesc, SizeOf(TImageDescriptor));
end;

procedure TGIF_Frame.WriteLocalColorMap(Stream: TStream);
begin
  if FLocalColors then
    with FImage.FColorMap do
      Stream.Write(Colors[0], Count * SizeOf(TGIFColorItem));
end;

procedure TGIF_Frame.WriteRasterData(Stream: TStream);
begin
  Stream.WriteBuffer(FImage.FImageData.Memory^, FImage.FImageData.Size);
end;

procedure TGIF_Frame.SaveToBitmapStream(Stream: TMemoryStream);

  function ConvertBitsPerPixel: TPixelFormat;
  begin
    Result := pfDevice;
    case FImage.FBitsPerPixel of
      1: Result := pf1bit;
      2..4: Result := pf4bit;
      5..8: Result := pf8bit;
      else GifError(LoadStr(SWrongGIFColors));
    end;
  end;

var
  HeaderSize: Longword;
  Length: Longword;
  BI: TBitmapInfoHeader;
  BitFile: TBitmapFileHeader;
  Colors: TRGBPalette;
  Bits: Pointer;
  Corrupt: Boolean;
begin
  with BI do begin
    biSize := Sizeof(TBitmapInfoHeader);
    biWidth := FImage.FSize.X;
    biHeight := FImage.FSize.Y;
    biPlanes := 1;
    biBitCount := 0;
    case ConvertBitsPerPixel of
      pf1bit: biBitCount := 1;
      pf4bit: biBitCount := 4;
      pf8bit: biBitCount := 8;
    end;
    biCompression := BI_RGB;
    biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  HeaderSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
    SizeOf(TRGBQuad) * (1 shl BI.biBitCount);
  Length := HeaderSize + BI.biSizeImage;
  Stream.SetSize(0);
  Stream.Position := 0;
  with BitFile do begin
    bfType := $4D42; { BM }
    bfSize := Length;
    bfOffBits := HeaderSize;
  end;
  Stream.Write(BitFile, SizeOf(TBitmapFileHeader));
  Stream.Write(BI, SizeOf(TBitmapInfoHeader));
  FillRGBPalette(FImage.FColorMap, Colors);
  Stream.Write(Colors, SizeOf(TRGBQuad) * (1 shl BI.biBitCount));
  Bits := AllocMemo(BI.biSizeImage);
  try
    ZeroMemory(Bits, BI.biSizeImage);
    FImage.FImageData.Position := 0;
    ReadGIFData(FImage.FImageData, BI, FInterlaced, GIFLoadCorrupted,
      FImage.FBitsPerPixel, Bits, Corrupt, FOwner.DoProgress);
    FCorrupted := FCorrupted or Corrupt;
    Stream.WriteBuffer(Bits^, BI.biSizeImage);
  finally
    FreeMemo(Bits);
  end;
  Stream.Position := 0;
end;

procedure TGIF_Frame.LoadFromStream(Stream: TStream);
var
  ImageDesc: TImageDescriptor;
  I, TransIndex: Integer;
begin
  FImage.FImageData := TMemoryStream.Create;
  try
    ReadImageStream(Stream, FImage.FImageData, ImageDesc, FInterlaced,
      FLocalColors, FCorrupted, FImage.FBitsPerPixel, FImage.FColorMap);
    if FCorrupted and not GIFLoadCorrupted then GifError(ResStr(SReadError));
    FImage.FImageData.Position := 0;
    with ImageDesc do begin
      if ImageHeight = 0 then ImageHeight := FOwner.FScreenHeight;
      if ImageWidth = 0 then ImageWidth := FOwner.FScreenWidth;
      FTopLeft := Point(ImageLeftPos, ImageTopPos);
      FImage.FSize := Point(ImageWidth, ImageHeight);
      FImage.FPackedFields := PackedFields;
    end;
    if not FLocalColors then FImage.FColorMap := FOwner.FImage.FColorMap;
    FAnimateInterval := 0;
    if FExtensions <> nil then begin
      for I := 0 to FExtensions.Count - 1 do
        with TExtension(FExtensions[I]) do
          if FExtType = etGraphic then begin
            if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then
            begin
              TransIndex := FExtRec.GCE.TransparentColorIndex;
              if FImage.FColorMap.Count > TransIndex then
                FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex]);
            end
            else FTransparentColor := clNone;
            FAnimateInterval := Max(FExtRec.GCE.DelayTime * 10,
              FAnimateInterval);
            FDisposal := TDisposalMethod((FExtRec.GCE.PackedFields and
              GCE_DISPOSAL_METHOD) shr 2);
          end;
    end;
  except
    FImage.FImageData.Free;
    FImage.FImageData := nil;
    raise;
  end;
end;

procedure TGIF_Frame.Draw(ACanvas: TCanvas; const ARect: TRect;
  Transparent: Boolean);
begin
  if (FTransparentColor <> clNone) and Transparent then begin
    with ARect do
      StretchBitmapRectTransparent(ACanvas, Left, Top, Right - Left,
        Bottom - Top, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap,
        FTransparentColor);
  end
  else ACanvas.StretchDraw(ARect, Bitmap);
end;

{ TGIFImage }

constructor TGIFImage.Create;
begin
  inherited Create;
  NewImage;
end;

destructor TGIFImage.Destroy;
begin
  OnChange := nil;
  FImage.Release;
  ClearItems;
  FItems.Free;
  inherited Destroy;
end;

procedure TGIFImage.Clear;
begin
  Assign(nil);
end;

procedure TGIFImage.ClearItems;
begin
  if FItems <> nil then
    while FItems.Count > 0 do begin
      TObject(FItems[0]).Free;
      FItems.Delete(0);
    end;
end;

procedure TGIFImage.Assign(Source: TPersistent);
var
  I: Integer;
  AFrame: TGIF_Frame;
begin
  if (Source = nil) then begin
    NewImage;
    Changed(Self);
  end
  else if (Source is TGIFImage) and (Source <> Self) then begin
    FImage.Release;
    FImage := TGIFImage(Source).FImage;
    FImage.Reference;
    FVersion := TGIFImage(Source).FVersion;
    FBackgroundColor := TGIFImage(Source).FBackgroundColor;
    FRepeatCount := TGIFImage(Source).FRepeatCount;
    FLooping := TGIFImage(Source).FLooping;
    FCorrupted := TGIFImage(Source).FCorrupted;
    if FItems = nil then FItems := TList.Create
    else ClearItems;
    with TGIFImage(Source) do begin
      for I := 0 to FItems.Count - 1 do begin
        AFrame := TGIF_Frame.Create(Self);
        try
          AFrame.FImage.FBitsPerPixel :=
            TGIF_Frame(FItems[I]).FImage.FBitsPerPixel;
          AFrame.Assign(TGIF_Frame(FItems[I]));
          AFrame.FLocalColors := TGIF_Frame(FItems[I]).FLocalColors;
          Self.FItems.Add(AFrame);
        except
          AFrame.Free;
          raise;
        end;
      end;
      Self.FScreenWidth := FScreenWidth;
      Self.FScreenHeight := FScreenHeight;
    end;
    FFrameIndex := TGIFImage(Source).FFrameIndex;
    Changed(Self);
  end
  else if Source is TGIF_Frame then begin
    NewImage;
    with TGIF_Frame(Source).FOwner.FImage do begin
      FImage.FAspectRatio := FAspectRatio;
      FImage.FBitsPerPixel := FBitsPerPixel;
      FImage.FColorResBits := FColorResBits;
      Move(FColorMap, FImage.FColorMap, SizeOf(FColorMap));
    end;
    FFrameIndex := FItems.Add(TGIF_Frame.Create(Self));
    TGIF_Frame(FItems[FFrameIndex]).Assign(Source);
    if FVersion = gvUnknown then FVersion := gv87a;
    Changed(Self);
  end
  else if Source is TBitmap then begin
    NewImage;
    AddFrame(TBitmap(Source));
    Changed(Self);
  end
  else if Source is TAnimatedCursorImage then begin
    NewImage;
    FBackgroundColor := clWindow;
    with TAnimatedCursorImage(Source) do begin
      for I := 0 to IconCount - 1 do begin
        AddFrame(TIcon(Icons[I]));
        Self.Frames[FrameIndex].FAnimateInterval :=
          Longint(Frames[I].JiffRate * 100) div 6;
      end;
    end;
    Changed(Self);
  end
  else inherited Assign(Source);
end;

procedure TGIFImage.AssignTo(Dest: TPersistent);
begin
  if Dest is TGIFImage then Dest.Assign(Self)
  else if Dest is TGraphic then begin
    if Empty then
      Dest.Assign(nil)
    else if FFrameIndex >= 0 then
      TGIF_Frame(FItems[FFrameIndex]).AssignTo(Dest)
    else Dest.Assign(Bitmap);
  end
  else inherited AssignTo(Dest);
end;

procedure TGIFImage.Draw(ACanvas: TCanvas; const ARect: TRect);
begin
  if FFrameIndex >= 0 then
    TGIF_Frame(FItems[FFrameIndex]).Draw(ACanvas, ARect, Self.Transparent);
end;

function TGIFImage.GetBackgroundColor: TColor;
begin
  Result := FBackgroundColor;
end;

procedure TGIFImage.SetBackgroundColor(Value: TColor);
begin
  if Value <> FBackgroundColor then begin
    FBackgroundColor := Value;
    Changed(Self);