gif_myrxgif.~pas

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

  end;
end;

procedure TGIFImage.SetLooping(Value: Boolean);
begin
  if Value <> FLooping then begin
    FLooping := Value;
    Changed(Self);
  end;
end;

procedure TGIFImage.SetRepeatCount(Value: Word);
begin
  if Min(Value, MAX_LOOP_COUNT) <> FRepeatCount then begin
    FRepeatCount := Min(Value, MAX_LOOP_COUNT);
    Changed(Self);
  end;
end;

function TGIFImage.GetPixelFormat: TPixelFormat;
var
  I: Integer;
begin
  Result := pfDevice;
  if not Empty then begin
    Result := ColorsToPixelFormat(FImage.FColorMap.Count);
    for I := 0 to FItems.Count - 1 do begin
      if (Frames[I].FImage.FImageData = nil) or
        (Frames[I].FImage.FImageData.Size = 0) then
      begin
        if Assigned(Frames[I].FBitmap) then
          Result := TPixelFormat(Max(Ord(Result),
            Ord(GetBitmapPixelFormat(Frames[I].FBitmap))))
        else Result := TPixelFormat(Max(Ord(Result), Ord(pfDevice)));
      end
      else if Frames[I].FLocalColors then
        Result := TPixelFormat(Max(Ord(Result),
          Ord(ColorsToPixelFormat(Frames[I].FImage.FColorMap.Count))));
    end;
  end;
end;

function TGIFImage.GetCorrupted: Boolean;
var
  I: Integer;
begin
  Result := FCorrupted;
  if not Result then
    for I := 0 to FItems.Count - 1 do
      if Frames[I].Corrupted then begin
        Result := True;
        Exit;
      end;
end;

function TGIFImage.GetTransparentColor: TColor;
begin
  if (FItems.Count > 0) and (FFrameIndex >= 0) then
    Result := TGIF_Frame(FItems[FFrameIndex]).FTransparentColor
  else Result := clNone;
end;

function TGIFImage.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TGIFImage.GetFrame(Index: Integer): TGIF_Frame;
begin
  Result := TGIF_Frame(FItems[Index]);
end;

procedure TGIFImage.SetFrameIndex(Value: Integer);
begin
  Value := Min(FItems.Count - 1, Max(-1, Value));
  if FFrameIndex <> Value then begin
    FFrameIndex := Value;
    Changed(Self);
  end;
end;

function TGIFImage.Equals(Graphic: TGraphic): Boolean;
begin
  Result := (Graphic is TGIFImage) and
    (FImage = TGIFImage(Graphic).FImage);
end;

function TGIFImage.GetBitmap: TBitmap;
var
  Bmp: TBitmap;
begin
  if (FItems.Count > 0) then begin
    if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
      Result := TGIF_Frame(FItems[FFrameIndex]).Bitmap
    else Result := TGIF_Frame(FItems[0]).Bitmap
  end
  else begin
    FFrameIndex := 0;
    Bmp := TBitmap.Create;
    try
      Bmp.Handle := 0;
      Assign(Bmp);
      Result := TGIF_Frame(FItems[FFrameIndex]).Bitmap;
    finally
      Bmp.Free;
    end;
  end;
end;

function TGIFImage.GetGlobalColorCount: Integer;
begin
  Result := FImage.FColormap.Count;
end;

function TGIFImage.GetEmpty: Boolean;
var
  I: Integer;
begin
  I := Max(FFrameIndex, 0);
  Result := (FItems.Count = 0) or
    ((TGIF_Frame(FItems[I]).FBitmap = nil) and
    ((TGIF_Frame(FItems[I]).FImage.FImageData = nil) or
    (TGIF_Frame(FItems[I]).FImage.FImageData.Size = 0)));
end;

function TGIFImage.GetPalette: HPalette;
begin
  if FItems.Count > 0 then Result := Bitmap.Palette
  else Result := 0;
end;

function TGIFImage.GetTransparent: Boolean;
var
  I: Integer;
begin
  for I := 0 to FItems.Count - 1 do
    if Frames[I].TransparentColor <> clNone then begin
      Result := True;
      Exit;
    end;
  Result := False;
end;

function TGIFImage.GetHeight: Integer;
begin
  if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
    Result := TGIF_Frame(FItems[FFrameIndex]).Bitmap.Height
  else Result := 0;
end;

function TGIFImage.GetWidth: Integer;
begin
  if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
    Result := TGIF_Frame(FItems[FFrameIndex]).Bitmap.Width
  else Result := 0;
end;

function TGIFImage.GetScreenWidth: Integer;
begin
  if Empty then Result := 0
  else Result := FScreenWidth;
end;

function TGIFImage.GetScreenHeight: Integer;
begin
  if Empty then Result := 0
  else Result := FScreenHeight;
end;

procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  Bmp: TBitmap;
  Stream: TMemoryStream;
  Size: Longint;
  Buffer: Pointer;
  Data: THandle;
begin
  { !! check for gif clipboard Data, mime type image/gif }
  Data := GetClipboardData(CF_GIF);
  if Data <> 0 then begin
    Buffer := GlobalLock(Data);
    try
      Stream := TMemoryStream.Create;
      try
        Stream.Write(Buffer^, GlobalSize(Data));
        Stream.Position := 0;
        Stream.Read(Size, SizeOf(Size));
        ReadStream(Size, Stream, False);
        if Count > 0 then begin
          FFrameIndex := 0;
          AData := GetClipboardData(CF_BITMAP);
          if AData <> 0 then begin
            Frames[0].NewBitmap;
            Frames[0].FBitmap.LoadFromClipboardFormat(CF_BITMAP,
              AData, APalette);
          end;
        end;
      finally
        Stream.Free;
      end;
    finally
      GlobalUnlock(Data);
    end;
  end
  else begin
    Bmp := TBitmap.Create;
    try
      Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
      Assign(Bmp);
    finally
      Bmp.Free;
    end;
  end;
end;

procedure TGIFImage.LoadFromStream(Stream: TStream);
begin
  ReadStream(Stream.Size - Stream.Position, Stream, True);
end;

procedure TGIFImage.LoadFromResourceName(Instance: THandle; const ResName: string;
  ResType: PChar);
var
  Stream: TStream;
begin
  Stream := TResourceStream.Create(Instance, ResName, ResType);
  try
    ReadStream(Stream.Size - Stream.Position, Stream, True);
  finally
    Stream.Free;
  end;
end;

procedure TGIFImage.LoadFromResourceID(Instance: THandle; ResID: Integer;
  ResType: PChar);
var
  Stream: TStream;
begin
  Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);
  try
    ReadStream(Stream.Size - Stream.Position, Stream, True);
  finally
    Stream.Free;
  end;
end;

procedure TGIFImage.UpdateScreenSize;
var
  I: Integer;
begin
  FScreenWidth := 0;
  FScreenHeight := 0;
  for I := 0 to FItems.Count - 1 do
    if Frames[I] <> nil then begin
      FScreenWidth := Max(FScreenWidth, Frames[I].Width +
        Frames[I].FTopLeft.X);
      FScreenHeight := Max(FScreenHeight, Frames[I].Height +
        Frames[I].FTopLeft.Y);
    end;
end;

function TGIFImage.AddFrame(Value: TGraphic): Integer;
begin
  FFrameIndex := FItems.Add(TGIF_Frame.Create(Self));
  TGIF_Frame(FItems[FFrameIndex]).Assign(Value);
  if FVersion = gvUnknown then FVersion := gv87a;
  if FItems.Count > 1 then FVersion := gv89a;
  Result := FFrameIndex;
end;

procedure TGIFImage.DeleteFrame(Index: Integer);
begin
  Frames[Index].Free;
  FItems.Delete(Index);
  UpdateScreenSize;
  if FFrameIndex >= FItems.Count then Dec(FFrameIndex);
  Changed(Self);
end;

procedure TGIFImage.MoveFrame(CurIndex, NewIndex: Integer);
begin
  FItems.Move(CurIndex, NewIndex);
  FFrameIndex := NewIndex;
  Changed(Self);
end;

procedure TGIFImage.NewImage;
begin
  if FImage <> nil then FImage.Release;
  FImage := TGIF_Data.Create;
  FImage.Reference;
  if FItems = nil then FItems := TList.Create;
  ClearItems;
  FCorrupted := False;
  FFrameIndex := -1;
  FBackgroundColor := clNone;
  FRepeatCount := 1;
  FLooping := False;
  FVersion := gvUnknown;
end;

procedure TGIFImage.UniqueImage;
var
  Temp: TGIF_Data;
begin
  if FImage = nil then NewImage
  else if FImage.RefCount > 1 then begin
    Temp := TGIF_Data.Create;
    with Temp do
    try
      FComment.Assign(FImage.FComment);
      FAspectRatio := FImage.FAspectRatio;
      FBitsPerPixel := FImage.FBitsPerPixel;
      FColorResBits := FImage.FColorResBits;
      FColorMap := FImage.FColorMap;
    except
      Temp.Free;
      raise;
    end;
    FImage.Release;
    FImage := Temp;
    FImage.Reference;
  end;
end;

function TGIFImage.GetComment: TStrings;
begin
  Result := FImage.FComment;
end;

procedure TGIFImage.SetComment(Value: TStrings);
begin
  UniqueImage;
  FImage.FComment.Assign(Value);
end;

procedure TGIFImage.DecodeAllFrames;
var
  FrameNo, I: Integer;
begin
  for FrameNo := 0 to FItems.Count - 1 do
    try
      TGIF_Frame(FItems[FrameNo]).GetBitmap;
    except
      on EAbort do begin { OnProgress can raise EAbort to cancel image load }
        for I := FItems.Count - 1 downto FrameNo do begin
          TObject(FItems[I]).Free;
          FItems.Delete(I);
        end;
        FCorrupted := True;
        Break;
      end;
      else raise;
    end;
end;

procedure TGIFImage.EncodeFrames(ReverseDecode: Boolean);
var
  FrameNo: Integer;
begin
  for FrameNo := 0 to FItems.Count - 1 do
    with TGIF_Frame(FItems[FrameNo]) do begin
      if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then
      begin
        FImage.FImageData.Free;
        FImage.FImageData := nil;
        EncodeRasterData;
        if ReverseDecode and (FBitmap.Palette = 0) then begin
          FBitmap.Free;
          FBitmap := nil;
          try
            GetBitmap;
          except
            on EAbort do; { OnProgress can raise EAbort to cancel encoding }
            else raise;
          end;
        end;
      end;
      UpdateExtensions;
    end;
end;

procedure TGIFImage.EncodeAllFrames;
begin
  EncodeFrames(True);
end;

procedure TGIFImage.ReadData(Stream: TStream);
var
  Size: Longint;
begin
  Stream.Read(Size, SizeOf(Size));
  ReadStream(Size, Stream, True);
end;

procedure TGIFImage.ReadSignature(Stream: TStream);
var
  I: TGIFVersion;
  S: string[3];
begin
  FVersion := gvUnknown;
  SetLength(S, 3);
  Stream.Read(S[1], 3);
  if CompareText(GIFSignature, S) <> 0 then GifError(LoadStr(SGIFVersion));
  SetLength(S, 3);
  Stream.Read(S[1], 3);
  for I := Low(TGIFVersion) to High(TGIFVersion) do
    if CompareText(S, StrPas(GIFVersionStr[I])) = 0 then begin
      FVersion := I;
      Break;
    end;
  if FVersion = gvUnknown then GifError(LoadStr(SGIFVersion));
end;

procedure TGIFImage.ReadStream(Size: Longint; Stream: TStream;
  ForceDecode: Boolean);
var
  SeparatorChar: Char;
  NewItem: TGIF_Frame;
  Extensions: TList;
  ScreenDesc: TScreenDescriptor;
  Data: TMemoryStream;

  procedure ReadScreenDescriptor(Stream: TStream);
  begin
    Stream.Read(ScreenDesc, SizeOf(ScreenDesc));
    FScreenWidth