rxgif.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

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: TGIFFrame;
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 := TGIFFrame.Create(Self);
        try
          AFrame.FImage.FBitsPerPixel :=
            TGIFFrame(FItems[I]).FImage.FBitsPerPixel;
          AFrame.Assign(TGIFFrame(FItems[I]));
          AFrame.FLocalColors := TGIFFrame(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 TGIFFrame then begin
    NewImage;
    with TGIFFrame(Source).FOwner.FImage do begin
      FImage.FAspectRatio := FAspectRatio;
      FImage.FBitsPerPixel := FBitsPerPixel;
      FImage.FColorResBits := FColorResBits;
      Move(FColorMap, FImage.FColorMap, SizeOf(FColorMap));
    end;
    FFrameIndex := FItems.Add(TGIFFrame.Create(Self));
    TGIFFrame(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
      TGIFFrame(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
    TGIFFrame(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);
  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 := TGIFFrame(FItems[FFrameIndex]).FTransparentColor
  else Result := clNone;
end;

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

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

procedure TGIFImage.SetFrameIndex(Value: Integer);
begin
  Value := Min(FItems.Count - 1, Max(-1, Value));
  if FFrameIndex <> Value then begin
    FFrameIndex := Value;
{$IFDEF RX_D3}
    PaletteModified := True;
{$ENDIF}
    Changed(Self);
  end;
end;

{$IFDEF WIN32}
function TGIFImage.Equals(Graphic: TGraphic): Boolean;
begin
  Result := (Graphic is TGIFImage) and
    (FImage = TGIFImage(Graphic).FImage);
end;
{$ENDIF}

function TGIFImage.GetBitmap: TBitmap;
var
  Bmp: TBitmap;
begin
  if (FItems.Count > 0) then begin
    if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then
      Result := TGIFFrame(FItems[FFrameIndex]).Bitmap
    else Result := TGIFFrame(FItems[0]).Bitmap
  end
  else begin
    FFrameIndex := 0;
    Bmp := TBitmap.Create;
    try
      Bmp.Handle := 0;
      Assign(Bmp);
      Result := TGIFFrame(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
    ((TGIFFrame(FItems[I]).FBitmap = nil) and
    ((TGIFFrame(FItems[I]).FImage.FImageData = nil) or
    (TGIFFrame(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
{$IFDEF RX_D3}
  if inherited GetTransparent then
{$ENDIF}
    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 := TGIFFrame(FItems[FFrameIndex]).Bitmap.Height
  else Result := 0;
end;

function TGIFImage.GetWidth: Integer;
begin
  if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then
    Result := TGIFFrame(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(TGIFFrame.Create(Self));
  TGIFFrame(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 := TGIFData.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: TGIFData;
begin
  if FImage = nil then NewImage
  else if FImage.RefCount > 1 then begin
    Temp := TGIFData.Create;
    with Temp do
    try
      FComment.Assign(FImage.FComment);
      FAspectRatio := FImage.F