Обработка анимированных GIF по рецепту китайского коллеги

[Вадим Смоленский]

Год назад в одной из веток проскочила ссылка на китайский сайт (http://www.raysoftware.cn/?p=559), где предлагалось готовое решение для показа анимированных гифок средствами FireMonkey на любых платформах. Сейчас эта ссылка, как и весь сайт raysoftware.cn, упорно не открывается; по счастью, контент сохранился в гугловском кэше. Я скопировал оттуда код юнита и перевел гуглом все китайские комментарии на английский, добавив их в скобках. Там был еще сопроводительный текст, в котором автор излагал мотивы, побудившие его взяться за эту проблему; каких-то важных технических деталей я в этом тексте не увидел.

Привожу весь юнит ниже и очень надеюсь, что кто-нибудь из продвинутых коллег объяснит мне, как именно этим кодом можно воспользоваться, чтобы показать пользователю анимированный файл в формате GIF. Моей программерской квалификации, к сожалению, не хватает.

Спойлер

 

unit FMX.GifUtils;

interface

uses
  System.Classes, System.SysUtils, System.Types, System.UITypes,
  FMX.Types, FMX.Objects, FMX.Graphics, System.Generics.Collections;

const
  alphaTransparent = $00;
  GifSignature: array [0 .. 2] of Byte = ($47, $49, $46); // GIF
  VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
  VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a

  GIF_DISPOSAL_UNSPECIFIED = 0;
  GIF_DISPOSAL_LEAVE = 1;
  GIF_DISPOSAL_BACKGROUND = 2;
  GIF_DISPOSAL_PREVIOUS = 3;

type
  TGifVer = (verUnknow, ver87a, ver89a);

  //
  TInternalColor = packed record
    case Integer of
      0:
        (

{$IFDEF BIGENDIAN}
          R, G, B, A: Byte;
{$ELSE}
          B, G, R, A: Byte;
{$ENDIF}
        );
      1:
        (Color: TAlphaColor;
        );
  end;

{$POINTERMATH ON}

  PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}

  TGifRGB = packed record
    R: Byte;
    G: Byte;
    B: Byte;
  end;

  TGIFHeader = packed record
    Signature: array [0 .. 2] of Byte;
    // * Header Signature (always "GIF") */
    Version: array [0 .. 2] of Byte;
    // * GIF format version("87a" or "89a") */
    // Logical Screen Descriptor
    ScreenWidth: word; // * Width of Display Screen in Pixels */
    ScreenHeight: word; // * Height of Display Screen in Pixels */
    Packedbit: Byte; // * Screen and Color Map Information */
    BackgroundColor: Byte; // * Background Color Index */
    AspectRatio: Byte; // * Pixel Aspect Ratio */
  end;

  TGifImageDescriptor = packed record
    Left: word;
    // * X position of image on the display */
    Top: word; // * Y position of image on the display */
    Width: word; // * Width of the image in pixels */
    Height: word; // * Height of the image in pixels */
    Packedbit: Byte; // * Image and Color Table Data Information */
  end;

  TGifGraphicsControlExtension = packed record
    BlockSize: Byte;
    // * Size of remaining fields (always 04h) */
    Packedbit: Byte; // * Method of graphics disposal to use */
    DelayTime: word; // * Hundredths of seconds to wait	*/
    ColorIndex: Byte; // * Transparent Color Index */
    Terminator: Byte; // * Block Terminator (always 0) */
  end;

  TGifReader = class;

  TPalette = TArray<TInternalColor>;

  TGifFrameItem = class;

  TGifFrameList = TObjectList<TGifFrameItem>;
  { TGifReader }

  TGifReader = class(TObject)
  protected
    FHeader: TGIFHeader;
    FPalette: TPalette;
    FScreenWidth: Integer;
    FScreenHeight: Integer;
    FInterlace: Boolean;
    FBitsPerPixel: Byte;
    FBackgroundColorIndex: Byte;
    FResolution: Byte;
    FGifVer: TGifVer;

  public
    function Read(Stream: TStream; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function Read(FileName: string; var AFrameList: TGifFrameList): Boolean;
      overload; virtual;
    function ReadRes(Instance: THandle; ResName: string; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;
    function ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
      var AFrameList: TGifFrameList): Boolean; overload; virtual;

    function Check(Stream: TStream): Boolean; overload; virtual;
    function Check(FileName: string): Boolean; overload; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    //
    property Header: TGIFHeader read FHeader;
    property ScreenWidth: Integer read FScreenWidth;
    property ScreenHeight: Integer read FScreenHeight;
    property Interlace: Boolean read FInterlace; // 是否是交织的  (Whether it is intertwined)
    property BitsPerPixel: Byte read FBitsPerPixel; // 颜色位   (Color bit)
    property Background: Byte read FBackgroundColorIndex; // 背景色   (Background color)
    property Resolution: Byte read FResolution; //
    property GifVer: TGifVer read FGifVer; // 版本，枚举类型   (Version, enumeration type)
  end;

  TGifFrameItem = class
    FDisposalMethod: Integer;
    FPos: TPoint;
    FTime: Integer;
    FDisbitmap: TBitmap;
  public
    destructor Destroy; override;
  end;

  TGifPlayer = class(TComponent)
  private
    FImage: TImage;
    FGifFrameList: TGifFrameList;
    FTimer: TTimer;
    FActiveFrameIndex: Integer;
    FSpeedup: Single;
    FScreenHeight: Integer;
    FScreenWidth: Integer;
    procedure SetImage(const Value: TImage);
    procedure TimerProc(Sender: TObject);
    function GetIsPlaying: Boolean;
    procedure SetActiveFrameIndex(const Value: Integer);
    procedure SetSpeedup(const Value: Single);
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure LoadFromFile(AFileName: string);
    procedure LoadFromStream(AStream: TStream);
    procedure LoadFromResById(Instance: THandle; ResId: Integer;
      ResType: PChar);
    procedure LoadFromResByName(Instance: THandle; ResName: string;
      ResType: PChar);
    procedure Play();
    procedure Pause();
    procedure stop();
    //
    property Image: TImage read FImage write SetImage;
    property IsPlaying: Boolean read GetIsPlaying;
    property Speedup: Single read FSpeedup write SetSpeedup;
    property ActiveFrameIndex: Integer read FActiveFrameIndex
      write SetActiveFrameIndex;
    property ScreenWidth: Integer read FScreenWidth;
    property ScreenHeight: Integer read FScreenHeight;
  end;

implementation

uses
  Math;

function swap16(x: UInt16): UInt16; inline;
begin
  Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;

function swap32(x: UInt32): UInt32; inline;
begin
  Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
    ((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;

function LEtoN(Value: word): word; overload;
begin
  Result := swap16(Value);
end;

function LEtoN(Value: Dword): Dword; overload;
begin
  Result := swap32(Value);
end;

{
  不知道为什么Windows下和Android中的Canvas.DrawBitmap对透明处理有区别，
  写这个函数来弥补这个区别

  I don't know why the Canvas.DrawBitmap between Windows and Android
  is different for transparent processing.
   Write this function to make up for this difference
}
procedure MergeBitmap(const Source, Dest: TBitmap; SrcRect: TRect;
  DestX, DestY: Integer);
var
  I, J, MoveBytes: Integer;
  SrcData, DestData: TBitmapData;
  lpColorSrc, lpColorDst: PInternalColor;
begin
  With Dest do
  begin
    if Map(TMapAccess.Write, DestData) then
      try
        if Source.Map(TMapAccess.Read, SrcData) then
          try
            if SrcRect.Left < 0 then
            begin
              Dec(DestX, SrcRect.Left);
              SrcRect.Left := 0;
            end;
            if SrcRect.Top < 0 then
            begin
              Dec(DestY, SrcRect.Top);
              SrcRect.Top := 0;
            end;
            SrcRect.Right := Min(SrcRect.Right, Source.Width);
            SrcRect.Bottom := Min(SrcRect.Bottom, Source.Height);
            if DestX < 0 then
            begin
              Dec(SrcRect.Left, DestX);
              DestX := 0;
            end;
            if DestY < 0 then
            begin
              Dec(SrcRect.Top, DestY);
              DestY := 0;
            end;
            if DestX + SrcRect.Width > Width then
              SrcRect.Width := Width - DestX;
            if DestY + SrcRect.Height > Height then
              SrcRect.Height := Height - DestY;

            if (SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom)
            then
            begin
              MoveBytes := SrcRect.Width * SrcData.BytesPerPixel;
              for I := 0 to SrcRect.Height - 1 do
              begin
                lpColorSrc := SrcData.GetPixelAddr(SrcRect.Left,
                  SrcRect.Top + I);
                lpColorDst := DestData.GetPixelAddr(DestX, DestY + I);
                for J := 0 to SrcRect.Width - 1 do
                  if lpColorSrc[J].A <> 0 then
                  begin
                    lpColorDst[J] := lpColorSrc[J];
                  end;
              end;
            end;
          finally
            Source.Unmap(SrcData);
          end;
      finally
        Unmap(DestData);
      end;
  end;
end;

{ TGifReader }

function TGifReader.Read(FileName: string;
  var AFrameList: TGifFrameList): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Read(fs, AFrameList);
  except

  end;
  fs.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResName: string; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.Create(HInstance, ResName, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.ReadRes(Instance: THandle; ResId: Integer; ResType: PChar;
  var AFrameList: TGifFrameList): Boolean;
var
  res: TResourceStream;
begin
  res := TResourceStream.CreateFromID(HInstance, ResId, ResType);
  Result := Read(res, AFrameList);
  res.DisposeOf;
end;

function TGifReader.Read(Stream: TStream;
  var AFrameList: TGifFrameList): Boolean;
var
  LDescriptor: TGifImageDescriptor;
  LGraphicsCtrlExt: TGifGraphicsControlExtension;
  LIsTransparent: Boolean;
  LGraphCtrlExt: Boolean;
  LFrameWidth: Integer;
  LFrameHeight: Integer;
  LLocalPalette: TPalette;
  LScanLineBuf: TBytes;
  // 读取调色板   (Reading palette)
  procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
  Var
    RGBEntry: TGifRGB;
    I: Integer;
    c: TInternalColor;
  begin
    SetLength(APalette, Size);
    For I := 0 To Size - 1 Do
    Begin
      Stream.Read(RGBEntry, SizeOf(RGBEntry));
      With APalette[I] do
      begin
        R := RGBEntry.R or (RGBEntry.R shl 8);
        G := RGBEntry.G or (RGBEntry.G shl 8);
        B := RGBEntry.B or (RGBEntry.B shl 8);
        A := $FF;
      end;
    End;
  end;
// 处理文件头，把文件头解析到对象的属性
// (Process file headers and parse file headers into object properties)
  function ProcHeader: Boolean;
  var
    c: TInternalColor;
  begin
    Result := False;
    With FHeader do
    begin
      if (CompareMem(@Signature, @GifSignature, 3)) and
        (CompareMem(@Version, @VerSignature87a, 3)) or
        (CompareMem(@Version, @VerSignature89a, 3)) then
      begin
        FScreenWidth := FHeader.ScreenWidth;
        FScreenHeight := FHeader.ScreenHeight;

        FResolution := Packedbit and $70 shr 5 + 1;
        FBitsPerPixel := Packedbit and 7 + 1; // 全局颜色表的大小，Packedbit+1就是颜色表的位数  (The size of the global color table, Packedbit+1 is the number of bits in the color table)
        FBackgroundColorIndex := BackgroundColor;
        if CompareMem(@Version, @VerSignature87a, 3) then
          FGifVer := ver87a
        else if CompareMem(@Version, @VerSignature89a, 3) then
          FGifVer := ver89a;
        Result := True;
      end
      else
        Raise Exception.Create('Unknown GIF image format');
    end;

  end;
// 处理一帧   (Handle a frame)
  function ProcFrame: Boolean;
  var
    LineSize: Integer;
    LBackColorIndex: Integer;
  begin
    Result := False;
    With LDescriptor do
    begin
      LFrameWidth := Width;
      LFrameHeight := Height;
      FInterlace := ((Packedbit and $40) = $40); // 交织标志   (Intertwined logo)
    end;

    if LGraphCtrlExt then
    begin
      LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
      If LIsTransparent then
        LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
    end
    else
    begin
      LIsTransparent := FBackgroundColorIndex <> 0;
      LBackColorIndex := FBackgroundColorIndex;
    end;
    LineSize := LFrameWidth * (LFrameHeight + 1);
    SetLength(LScanLineBuf, LineSize);
    // 如果有透明，就把透明色的调色板中的颜色的Alpha值改成透明的
    // (If transparent, change the alpha value of the color in the transparent palette to transparent)
    If LIsTransparent then
    begin
      LLocalPalette[LBackColorIndex].A := alphaTransparent;
    end;
    Result := True;
  end;

// 处理块  (Processing block)
  function ReadAndProcBlock(Stream: TStream): Byte;
  var
    Introducer, Labels, SkipByte: Byte;
  begin
    Stream.Read(Introducer, 1);
    if Introducer = $21 then
    begin
      Stream.Read(Labels, 1);
      Case Labels of
        $FE, $FF:
          // Comment Extension block or Application Extension block
          while True do
          begin
            Stream.Read(SkipByte, 1);
            if SkipByte = 0 then
              Break;
            Stream.Seek(Int64( SkipByte), soFromCurrent);
          end;
        $F9: // Graphics Control Extension block
          begin
            Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
            LGraphCtrlExt := True;
          end;
        $01: // Plain Text Extension block
          begin
            Stream.Read(SkipByte, 1);
            Stream.Seek(Int64( SkipByte), soFromCurrent);
            while True do
            begin
              Stream.Read(SkipByte, 1);
              if SkipByte = 0 then
                Break;
              Stream.Seek(Int64( SkipByte), soFromCurrent);
            end;
          end;
      end;
    end;
    Result := Introducer;
  end;
// 把一帧图像解析到ScanLine   (Analyze a frame of image to ScanLine)
  function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
  var
    OldPos, UnpackedSize, PackedSize: longint;
    I: Integer;
    Data, Bits, Code: Cardinal;
    SourcePtr: PByte;
    InCode: Cardinal;

    CodeSize: Cardinal;
    CodeMask: Cardinal;
    FreeCode: Cardinal;
    OldCode: Cardinal;
    Prefix: array [0 .. 4095] of Cardinal;
    Suffix, Stack: array [0 .. 4095] of Byte;
    StackPointer: PByte;
    Target: PByte;
    DataComp: TBytes;
    B, FInitialCodeSize, FirstChar: Byte;
    ClearCode, EOICode: word;
  begin
    DataComp := nil;
    try
      try
        // 读取目录大小   (Read directory size)
        Stream.Read(FInitialCodeSize, 1);

        // 找到压缩表的结束位置   (Find the end of the compressed table)
        OldPos := Stream.Position;
        PackedSize := 0;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Inc(PackedSize, B);
            Stream.Seek(Int64(B), soFromCurrent);
            CodeMask := (1 shl CodeSize) - 1;
          end;
        until B = 0;

        SetLength(DataComp, 2 * PackedSize);
        // 读取压缩表    (Read the compression table)
        SourcePtr := @DataComp[0];
        Stream.Position := OldPos;
        Repeat
          Stream.Read(B, 1);
          if B > 0 then
          begin
            Stream.ReadBuffer(SourcePtr^, B);
            Inc(SourcePtr, B);
          end;
        until B = 0;

        SourcePtr := @DataComp[0];
        Target := AScanLine;
        CodeSize := FInitialCodeSize + 1;
        ClearCode := 1 shl FInitialCodeSize;
        EOICode := ClearCode + 1;
        FreeCode := ClearCode + 2;
        OldCode := 4096;
        CodeMask := (1 shl CodeSize) - 1;
        UnpackedSize := LFrameWidth * LFrameHeight;
        for I := 0 to ClearCode - 1 do
        begin
          Prefix[I] := 4096;
          Suffix[I] := I;
        end;
        StackPointer := @Stack;
        FirstChar := 0;
        Data := 0;
        Bits := 0;
        // 解压LZW   (Unzip LZW)
        while (UnpackedSize > 0) and (PackedSize > 0) do
        begin
          Inc(Data, SourcePtr^ shl Bits);
          Inc(Bits, 8);
          while Bits >= CodeSize do
          begin
            Code := Data and CodeMask;
            Data := Data shr CodeSize;
            Dec(Bits, CodeSize);
            if Code = EOICode then
              Break;
            if Code = ClearCode then
            begin
              CodeSize := FInitialCodeSize + 1;
              CodeMask := (1 shl CodeSize) - 1;
              FreeCode := ClearCode + 2;
              OldCode := 4096;
              Continue;
            end;
            if Code > FreeCode then
              Break;
            if OldCode = 4096 then
            begin
              FirstChar := Suffix[Code];
              Target^ := FirstChar;
              Inc(Target);
              Dec(UnpackedSize);
              OldCode := Code;
              Continue;
            end;
            InCode := Code;
            if Code = FreeCode then
            begin
              StackPointer^ := FirstChar;
              Inc(StackPointer);
              Code := OldCode;
            end;
            while Code > ClearCode do
            begin
              StackPointer^ := Suffix[Code];
              Inc(StackPointer);
              Code := Prefix[Code];
            end;
            FirstChar := Suffix[Code];
            StackPointer^ := FirstChar;
            Inc(StackPointer);
            Prefix[FreeCode] := OldCode;
            Suffix[FreeCode] := FirstChar;
            if (FreeCode = CodeMask) and (CodeSize < 12) then
            begin
              Inc(CodeSize);
              CodeMask := (1 shl CodeSize) - 1;
            end;
            if FreeCode < 4095 then
              Inc(FreeCode);
            OldCode := InCode;
            repeat
              Dec(StackPointer);
              Target^ := StackPointer^;
              Inc(Target);
              Dec(UnpackedSize);
            until StackPointer = @Stack;
          end;
          Inc(SourcePtr);
          Dec(PackedSize);
        end;

      finally
        DataComp := nil;
      end;
    except

    end;
    Result := True;
  end;
// 把ScanLine写到我们常用的图像   (Write ScanLine to our usual image)
  function WriteScanLine(var Img: TBitmap; AScanLine: PByte): Boolean;
  Var
    Row, Col: Integer;
    Pass, Every: Byte;
    P: PByte;
    function IsMultiple(NumberA, NumberB: Integer): Boolean;
    begin
      Result := (NumberA >= NumberB) and (NumberB > 0) and
        (NumberA mod NumberB = 0);
    end;

  var
    PLine: PInternalColor;
    Data: TBitmapData;
  begin
    Result := False;
    P := AScanLine;
    if Img.Map(TMapAccess.Write, Data) then
    begin
      try
        // 如果是交织的   (If it is intertwined)
        If FInterlace then
        begin
          For Pass := 1 to 4 do
          begin
            Case Pass of
              1:
                begin
                  Row := 0;
                  Every := 8;
                end;
              2:
                begin
                  Row := 4;
                  Every := 8;
                end;
              3:
                begin
                  Row := 2;
                  Every := 4;
                end;
              4:
                begin
                  Row := 1;
                  Every := 2;
                end;
            end;
            PLine := Data.GetScanline(Row);
            Repeat
              for Col := 0 to Img.Width - 1 do
              begin
                PLine[Col] := LLocalPalette[P^];
                Inc(P);
              end;
              Inc(Row, Every);
            until Row >= Img.Height;
          end;
        end
        else
        begin
          for Row := 0 to Img.Height - 1 do
          begin
            PLine := Data.GetScanline(Row);
            for Col := 0 to Img.Width - 1 do
            begin
              PLine[Col] := LLocalPalette[P^];
              Inc(P);
            end;
          end;
        end;
        Result := True;
      finally
        Img.Unmap(Data);
      end;
    end;
  end;

var
  Introducer: Byte;
  ColorTableSize: Integer;
  tmp: TBitmap;
  LFrame: TGifFrameItem;
  FrameIndex: Integer;
  I: Integer;
begin
  Result := False;
  if not Check(Stream) then
    Exit;
  AFrameList.Clear;
  FGifVer := verUnknow;
  FPalette := nil;
  LScanLineBuf := nil;
  try

    Stream.Position := 0;
    // 读文件头   (Read file header)
    Stream.Read(FHeader, SizeOf(FHeader));

    // 字节序   (Byte order)
{$IFDEF BIGENDIAN}
    with FHeader do
    begin
      ScreenWidth := LEtoN(ScreenWidth);
      ScreenHeight := LEtoN(ScreenHeight);
    end;
{$ENDIF}
    // 如果有全局的调色板   (If there is a global palette)
    if (FHeader.Packedbit and $80) = $80 then
    begin
      ColorTableSize := FHeader.Packedbit and 7 + 1;
      ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
    end;

    // 处理头   (Processing head)
    if not ProcHeader then
      Exit;

    FrameIndex := 0;
    while True do
    begin
      LLocalPalette := nil;
      Repeat
        Introducer := ReadAndProcBlock(Stream);
      until (Introducer in [$2C, $3B]); // 2C每一帧的标识，3B文件结尾标志   (2C identification of each frame, 3B file end marker)
      if Introducer = $3B then
        Break;

      // 描述符   (Descriptor)
      Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
      with FDescriptor do
      begin
        Left := LEtoN(Left);
        Top := LEtoN(Top);
        Width := LEtoN(Width);
        Height := LEtoN(Height);
      end;
{$ENDIF}
      // 如果有本地调色板，就是用本地调色板，否则复制全局调色板
      // (If you have a local palette, use the local palette, otherwise copy the global palette)
      if (LDescriptor.Packedbit and $80) <> 0 then
      begin
        ColorTableSize := LDescriptor.Packedbit and 7 + 1;
        ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
      end
      else
      begin
        LLocalPalette := Copy(FPalette, 0, Length(FPalette));
      end;

      if not ProcFrame then
        Exit;
      // 创建图片   (Create a picture)
      LFrame := TGifFrameItem.Create;
      LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime;
      LFrame.FDisbitmap := TBitmap.Create(FScreenWidth, FScreenHeight);
      tmp := TBitmap.Create(LFrameWidth, LFrameHeight);
      LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top);
      LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2);
      // 读取ScanLine   (Read ScanLine)
      if not ReadScanLine(Stream, @LScanLineBuf[0]) then
        Exit;
      // 写ScanLine   (Write ScanLine)
      if not WriteScanLine(tmp, @LScanLineBuf[0]) then
        Exit;
      if FrameIndex = 0 then
      begin // 第0个强制视为 DisposalMethod = GIF_DISPOSAL_UNSPECIFIED   (The 0th mandatory as DisposalMethod = GIF_DISPOSAL_UNSPECIFIED)
        LFrame.FDisbitmap.Clear(LLocalPalette[FBackgroundColorIndex].Color);
        MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
          LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
        // CoverData(LFrame.FDisbitmap, tmp, Bounds(LFrame.FPos.X, LFrame.FPos.Y,
        // LFrameWidth, LFrameHeight), Rect(0, 0, LFrameWidth, LFrameHeight));
      end
      else
      begin

        case AFrameList[AFrameList.Count - 1].FDisposalMethod of
          GIF_DISPOSAL_UNSPECIFIED, // 不处理   (Do not handle)
          GIF_DISPOSAL_LEAVE: // 不处置图形，把图形从当前位置移去,重绘背景，在背景基础上画新的一帧  (Does not deal with graphics, remove the graphics from the current position, redraw the background, draw a new frame based on the background)
            begin
              LFrame.FDisbitmap.CopyFromBitmap(AFrameList[AFrameList.Count - 1]
                .FDisbitmap);
              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          GIF_DISPOSAL_BACKGROUND: // 恢复到背景色   (Revert to background color)
            begin
              LFrame.FDisbitmap.Clear
                (LLocalPalette[FBackgroundColorIndex].Color);

              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          GIF_DISPOSAL_PREVIOUS: // 回复到先前状态   (Revert to previous status)
            begin
              // 向前追溯到关键帧，如果没用就是第0帧   (Trace back to the keyframe, if it is not used is the 0th frame)
              for I := AFrameList.Count - 1 downto 0 do
              begin
                if (AFrameList[I].FDisposalMethod = GIF_DISPOSAL_BACKGROUND)
                then
                  Break;
              end;
              if I < 0 then
                I := 0;

              LFrame.FDisbitmap.CopyFromBitmap(AFrameList[I].FDisbitmap);

              MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth,
                LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
            end;
          4 .. 7: // 自定义处理，咋处理，不知道。。。   (Custom processing, processing, do not know. . .)
            begin
            end;
        end;

      end;
      AFrameList.Add(LFrame);
      // tmp.SaveToFile(Format('d:\test%d.png', [FrameIndex]));
      // LFrame.FDisbitmap.SaveToFile(Format('d:\test%d.png', [FrameIndex]));
      tmp.DisposeOf;
      Inc(FrameIndex);
    end;
    Result := True;
  finally
    LLocalPalette := nil;
    LScanLineBuf := nil;
  end;
end;

function TGifReader.Check(Stream: TStream): Boolean;
var
  OldPos: Int64;
begin
  try
    OldPos := Stream.Position;
    Stream.Read(FHeader, SizeOf(FHeader));
    Result := (CompareMem(@FHeader.Signature, @GifSignature, 3)) and
      (CompareMem(@FHeader.Version, @VerSignature87a, 3)) or
      (CompareMem(@FHeader.Version, @VerSignature89a, 3));
    Stream.Position := OldPos;
  except
    Result := False;
  end;
end;

function TGifReader.Check(FileName: string): Boolean;
var
  fs: TFileStream;
begin
  Result := False;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Check(fs);
  except

  end;
  fs.DisposeOf;
end;

constructor TGifReader.Create;
begin
  inherited Create;

end;

destructor TGifReader.Destroy;
begin

  inherited Destroy;
end;

{ TGifFrameItem }

destructor TGifFrameItem.Destroy;
begin
  if FDisbitmap <> nil then
  begin
    FDisbitmap.DisposeOf;
    FDisbitmap := nil;
  end;
  inherited Destroy;
end;

{ TGifPlayer }

constructor TGifPlayer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGifFrameList := TGifFrameList.Create();
  FTimer := TTimer.Create(Self);
  FTimer.Enabled := False;
  FTimer.OnTimer := TimerProc;
  FSpeedup := 1.0;
end;

destructor TGifPlayer.Destroy;
begin
  FTimer.Enabled := False;
  FGifFrameList.DisposeOf;
  FGifFrameList := nil;
  inherited Destroy;
end;

function TGifPlayer.GetIsPlaying: Boolean;
begin
  Result := FTimer.Enabled;
end;

procedure TGifPlayer.LoadFromFile(AFileName: string);
var
  gr: TGifReader;
begin
  gr := TGifReader.Create;
  gr.Read(AFileName, FGifFrameList);
  FScreenWidth := gr.ScreenWidth;
  FScreenHeight := gr.ScreenHeight;
  gr.DisposeOf;
  ActiveFrameIndex := 0;
end;

procedure TGifPlayer.LoadFromResById(Instance: THandle; ResId: Integer;
  ResType: PChar);
var
  gr: TGifReader;
begin
  gr := TGifReader.Create;
  gr.ReadRes(Instance, ResId, ResType, FGifFrameList);
  FScreenWidth := gr.ScreenWidth;
  FScreenHeight := gr.ScreenHeight;
  gr.DisposeOf;
  ActiveFrameIndex := 0;
end;

procedure TGifPlayer.LoadFromResByName(Instance: THandle; ResName: string;
  ResType: PChar);
var
  gr: TGifReader;
begin
  gr := TGifReader.Create;
  gr.ReadRes(Instance, ResName, ResType, FGifFrameList);
  FScreenWidth := gr.ScreenWidth;
  FScreenHeight := gr.ScreenHeight;
  gr.DisposeOf;
  ActiveFrameIndex := 0;
end;

procedure TGifPlayer.LoadFromStream(AStream: TStream);
var
  gr: TGifReader;
begin
  gr := TGifReader.Create;
  gr.Read(AStream, FGifFrameList);
  FScreenWidth := gr.ScreenWidth;
  FScreenHeight := gr.ScreenHeight;
  gr.DisposeOf;
  ActiveFrameIndex := 0;
end;

procedure TGifPlayer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
  begin
    if AComponent = FImage then
      FImage := nil;
  end;
end;

procedure TGifPlayer.Pause;
begin
  FTimer.Enabled := False;
end;

procedure TGifPlayer.Play;
begin
  if not IsPlaying then
  begin
    ActiveFrameIndex := FActiveFrameIndex;
    FTimer.Enabled := True;
  end;
end;

procedure TGifPlayer.SetActiveFrameIndex(const Value: Integer);
var
  lInterval: Integer;
begin
  // if (FActiveFrameIndex <> Value) then
  begin
    FActiveFrameIndex := Value;
    if (FActiveFrameIndex < 0) or (FActiveFrameIndex >= FGifFrameList.Count)
    then
      FActiveFrameIndex := -1;
    if (FActiveFrameIndex >= 0) and (FActiveFrameIndex < FGifFrameList.Count)
    then
    begin
      if FImage <> nil then
      begin
        FImage.Bitmap.Assign(FGifFrameList[FActiveFrameIndex].FDisbitmap);
      end;
      lInterval := FGifFrameList[FActiveFrameIndex].FTime;
      if lInterval = 0 then
        lInterval := 100;
      lInterval := Trunc(lInterval / FSpeedup);
      if lInterval <= 3 then
        lInterval := 3;
      FTimer.Interval := lInterval;
    end
    else
    begin
      FImage.Bitmap.SetSize(0, 0);
      FTimer.Interval := 0;
    end;
  end;
end;

procedure TGifPlayer.SetImage(const Value: TImage);
begin
  FImage := Value;
  if FImage <> nil then
    FImage.FreeNotification(Self);
end;

procedure TGifPlayer.SetSpeedup(const Value: Single);
begin
  if FSpeedup <> Value then
  begin
    FSpeedup := Value;
    if FSpeedup <= 0.001 then
      FSpeedup := 0.001;
  end;
end;

procedure TGifPlayer.stop;
begin
  Pause;
  FActiveFrameIndex := 0;
end;

procedure TGifPlayer.TimerProc(Sender: TObject);
var
  Interval: Integer;
begin
  if ([csDesigning, csDestroying, csLoading] * ComponentState) <> [] then
    Exit;
  FTimer.Enabled := False;
  if ActiveFrameIndex < (FGifFrameList.Count - 1) then
    ActiveFrameIndex := FActiveFrameIndex + 1
  else
    ActiveFrameIndex := 0;
  FTimer.Enabled := True;
end;

end.

 

[Евгений Корепов]

Принцип работы такой:

1. На форму кладете стандартный TImage
2. Создаете экземпляр TGifPlayer
3. Задаете свойство FGifPlayer.Image:=Image; где Image это лежащая на форме TImage
4. Загружаете гифку FGifPlayer.LoadFromFile('D:\Embarcadero\Projects\ShareCode\FMX.GifUtils\GIF_Example.gif');
5. Запускаем проигрывание гифки FGifPlayer.Play;

Вот код:

unit UnitFormMain;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.GifUtils, FMX.Objects;

type
  TFormMain = class(TForm)
    Image: TImage;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FGifPlayer : TGifPlayer;
  end;

var
  FormMain: TFormMain;

implementation

{$R *.fmx}

procedure TFormMain.FormCreate(Sender: TObject);
begin
  FGifPlayer:=TGifPlayer.Create(Self);
  FGifPlayer.Image:=Image;
  FGifPlayer.LoadFromFile('D:\Embarcadero\Projects\ShareCode\FMX.GifUtils\GIF_Example.gif');
  FGifPlayer.Play;
end;

end.

Вот демо проект во вложении:

 

FMX.GifUtils.Demo.zip

[Вадим Смоленский]

Всё отлично заработало, спасибо за инструкции. Особенно радует, что можно менять скорость анимации (TGifPlayer.SetupSpeed) и ставить ее на паузу (TGifPlayer.Pause). Правда, для этого в исходном юните кое-что пришлось переместить из private в public.

У Сисун (так зовут китайского умельца, если я правильно транскрибировал Wǔ Xīsōng) заслуживает самой глубокой благодарности.

[IVGSoft]

В 04.05.2018 в 12:57, Вадим Смоленский сказал:

GIF_DISPOSAL_BACKGROUND: // 恢复到背景色 (Revert to background color) begin LFrame.FDisbitmap.Clear (LLocalPalette[FBackgroundColorIndex].Color); MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y); end;

В этом участке кода есть одна маленькая ошибка. Иногда это приводит к тому, что на некоторых кадрах теряется прозрачность.

Я заменил на вот такое :

GIF_DISPOSAL_BACKGROUND:
	begin
	  LFrame.FDisbitmap.Clear(LLocalPalette[LGraphicsCtrlExt.ColorIndex].Color);
	  MergeBitmap(tmp, LFrame.FDisbitmap, Bounds(0, 0, LFrameWidth, LFrameHeight), LFrame.FPos.x, LFrame.FPos.Y);
	end;

 

[IVGSoft]

Чем больше пользую, тем больше багов вылазит

Пытаюсь исправить. У этого класса есть проблемы с отображением черезстрочных (interlaced) гифок.

[Вадим Смоленский]

6 часов назад, IVGSoft сказал:

Пытаюсь исправить.

Хорошо, если получится исправить. В моем-то проекте гифки самые простые, без прозрачности и черезстрочности, так что я ничего такого и не заметил.

[IVGSoft]

12 часов назад, Вадим Смоленский сказал:

Хорошо, если получится исправить. В моем-то проекте гифки самые простые, без прозрачности и черезстрочности, так что я ничего такого и не заметил.

В конце концов получилось исправить.

Для interlaced гифок проблема была вообще пустяковая. Одна строчка не в том месте. А вот для optimized все оказалось несколько сложней, но в итоге теперь все гифки отображаются правильно.

Пользуйтесь на здоровье!

FMX.GifUtils.zip

Изменено 20 июня, 2018 пользователем IVGSoft

[Roma77751]

В 20.06.2018 в 15:12, IVGSoft сказал:

В конце концов получилось исправить.

Для interlaced гифок проблема была вообще пустяковая. Одна строчка не в том месте. А вот для optimized все оказалось несколько сложней, но в итоге теперь все гифки отображаются правильно.

Пользуйтесь на здоровье!

FMX.GifUtils.zip

Доброго времени суток! в твоем коде делфя ругается на эту строчку

"  MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);"

а конкретно на" aFrames[Index].Bitmap.Bounds"

подскажи что не так плз...чет не могу разобраться

[IVGSoft]

В 23.11.2018 в 21:28, Roma77751 сказал:

Доброго времени суток! в твоем коде делфя ругается на эту строчку

"  MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);"

а конкретно на" aFrames[Index].Bitmap.Bounds"

подскажи что не так плз...чет не могу разобраться

Конкретней можно? Какую ошибку выдает? Какая версия Дельфи?

[Roma77751]

53 минуты назад, IVGSoft сказал:

Конкретней можно? Какую ошибку выдает? Какая версия Дельфи?

Delphi XE7 

[dcc32 Hint] FMX.GifUtils.pas(246): H2077 Value assigned to 'MoveBytes' never used
[dcc32 Warning] FMX.GifUtils.pas(418): W1000 Symbol 'Seek' is deprecated
[dcc32 Warning] FMX.GifUtils.pas(428): W1000 Symbol 'Seek' is deprecated
[dcc32 Warning] FMX.GifUtils.pas(434): W1000 Symbol 'Seek' is deprecated
[dcc32 Warning] FMX.GifUtils.pas(473): W1000 Symbol 'Seek' is deprecated
[dcc32 Error] FMX.GifUtils.pas(683): E2003 Undeclared identifier: 'Bounds'
[dcc32 Error] FMX.GifUtils.pas(698): E2003 Undeclared identifier: 'Bounds'
[dcc32 Fatal Error] Unit1.pas(7): F2063 Could not compile used unit 'FMX.GifUtils.pas'
Failed

[Roma77751]

Я не особо разбираюсь, но чтобы делфи не материлась сделал так            

MergeBitmap(aFrames.Bitmap, aDisplay, Bounds(0,0,aframes.Bitmap.Width,aframes.bitmap.Height),aFrames.FPos.X, aFrames.FPos.Y);

так компилируется, но все все равно синее

[CyberStorm]

Кстати сейчас сайт китайца отлично открывается  Китайцы вообще молодцы, и делфи самые первые ломают и кряки делают и модули всякие  

[Roma77751]

13 часов назад, CyberStorm сказал:

Кстати сейчас сайт китайца отлично открывается  Китайцы вообще молодцы, и делфи самые первые ломают и кряки делают и модули всякие  

Да.. по китайски но делают 

[IVGSoft]

19 часов назад, Roma77751 сказал:

так компилируется, но все все равно синее

Не помню, чтобы с таким сталкивался. Возможно где-то ошибка в исходниках FMX. Похоже на то, что перепутаны местами каналы R и B

[dnekrasov]

20 минут назад, IVGSoft сказал:

Не помню, чтобы с таким сталкивался. Возможно где-то ошибка в исходниках FMX. Похоже на то, что перепутаны местами каналы R и B

 

[Roma77751]

В 04.05.2018 в 15:57, Вадим Смоленский сказал:

2 часа назад, IVGSoft сказал:

Не помню, чтобы с таким сталкивался. Возможно где-то ошибка в исходниках FMX. Похоже на то, что перепутаны местами каналы R и B

 

 

[HackerGROOVEDima]

В 27.11.2018 в 17:03, IVGSoft сказал:

Не помню, чтобы с таким сталкивался. Возможно где-то ошибка в исходниках FMX. Похоже на то, что перепутаны местами каналы R и B

Привет, с fmxutils почему-то гиф заедает, вроде бы на последнем кадре, когда к первому возвращается, я всё никак понять не могу почему

100-AnimatedGIF.7z