FireMonkey跨平台的GIF解决方案

用FireMonkey的同学们一定知道FireMonkey对GIF动画的支持不是太好,只有静态的。

网上已有的解决方案就是先手动预处理GIF文件分割成多个单张,然后放到BitmapList中,缺点是要手动处理,而且帧速率也麻烦。因为项目中要实现了一个GIF的格式处理,代码整理了一下,嫁接到FireMonkey中,给广大兄弟们使用。

主要是就实现一个GIF格式的Reader,把GIF每一帧解析出来变成TBitmap,帧速率读出来,按照指定的帧速率播放。

之前用GDIPlus写了一份,但是有两个原因促使我自己重头写。

1)GDIPlus不能跨平台只支持Windows,

2)效率偏低。也用FreeImage试过,FreeImage对静态图还可以,获取GIF帧极其慢,40毫秒解析出一帧,几百帧要等死人的。改GDIPlus好一些,但是也慢。我自己解析GIF的话,比GDIPlus的快接近一倍。GDIPlus解析要900-1000ms,这个只要500ms

因为这份代码是直接自己解析GIF文件格式的,理论上可以跨任何Delphi支持的平台。

自己测试Win32,Win64,Android,FMX for Linux 0.91无问题。

screen

 

代码和例子:FMXGif

控件部分的代码如下:

{
  GIF文件格式解析。
  参考:http://blog.csdn.net/wzy198852/article/details/17266507

http://wenku.baidu.com/link?url=lLsRy13yNCOTdeJLHpLejRvPV_Qz9X_E1ZupyiVXL3-TaE8SFdiFM78YFm50436pD1TwgZO833a5vyrmiwi8n1xDGmLvJph6TE5TyIYiRg3###

  by  wr960204武稀松  2016.11.30
  可以给FMX播放GIF的控件

  大概用法

  2016.12.7
  2017.4.19加入对FMX for Linux的支持
}

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; // 是否是交织的
    property BitsPerPixel: Byte read FBitsPerPixel; // 颜色位
    property Background: Byte read FBackgroundColorIndex; // 背景色
    property Resolution: Byte read FResolution; //
    property GifVer: TGifVer read FGifVer; // 版本,枚举类型
  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对透明处理有区别,
  写这个函数来弥补这个区别
}
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;
  // 读取调色板
  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;
// 处理文件头,把文件头解析到对象的属性
  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就是颜色表的位数
        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;
// 处理一帧
  function ProcFrame: Boolean;
  var
    LineSize: Integer;
    LBackColorIndex: Integer;
  begin
    Result := False;
    With LDescriptor do
    begin
      LFrameWidth := Width;
      LFrameHeight := Height;
      FInterlace := ((Packedbit and $40) = $40); // 交织标志
    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 LIsTransparent then
    begin
      LLocalPalette[LBackColorIndex].A := alphaTransparent;
    end;
    Result := True;
  end;

// 处理块
  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
  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
        // 读取目录大小
        Stream.Read(FInitialCodeSize, 1);

        // 找到压缩表的结束位置
        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);
        // 读取压缩表
        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
        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写到我们常用的图像
  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 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;
    // 读文件头
    Stream.Read(FHeader, SizeOf(FHeader));

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

    // 处理头
    if not ProcHeader then
      Exit;

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

      // 描述符
      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 (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;
      // 创建图片
      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
      if not ReadScanLine(Stream, @LScanLineBuf[0]) then
        Exit;
      // 写ScanLine
      if not WriteScanLine(tmp, @LScanLineBuf[0]) then
        Exit;
      if FrameIndex = 0 then
      begin // 第0个强制视为 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, // 不处理
          GIF_DISPOSAL_LEAVE: // 不处置图形,把图形从当前位置移去,重绘背景,在背景基础上画新的一帧
            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: // 恢复到背景色
            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: // 回复到先前状态
            begin
              // 向前追溯到关键帧,如果没用就是第0帧
              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: // 自定义处理,咋处理,不知道。。。
            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.

 

 

 

 

此条目发表在Delphi分类目录,贴了, , , , 标签。将固定链接加入收藏夹。

FireMonkey跨平台的GIF解决方案》有 4 条评论

  1. wesley bobato说:

    Delphi Tokyo 10.2.2 Build 2004 Win32/64

    Hello Friend.

    Thank you for sharing :)

    unfortunately the transparency does not work properly.

    https://storage.googleapis.com/live_project_images_0005/15/1412210-l-1484298010.gif

    Can you check this, please?

    thank you

    —————————————————————————————————
    你好朋友。

    非常感谢分享:)

    不幸的是透明度不能正常工作。

    https://storage.googleapis.com/live_project_images_0005/15/1412210-l-1484298010.gif

    你能检查一下吗?

    谢谢

  2. Alitrun说:

    Please update your GIF unit, our community fixed some bugs:
    http://fire-monkey.ru/topic/5093-производительность-отрисовки-текста-на-мобильных-платформах/?page=2#comment-32397
    Thank you.

    https://drive.google.com/file/d/1WV-eRWRjfMdYJ9y9y2H8EMypvgCUM1hH/view

    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;

    TGifFrameItem = class;

    TGifFrameList = TObjectList;
    { 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;
    property BitsPerPixel: Byte read FBitsPerPixel;
    property Background: Byte read FBackgroundColorIndex;
    property Resolution: Byte read FResolution;
    property GifVer: TGifVer read FGifVer;
    end;

    TGifFrameItem = class
    FDisposalMethod: Integer;
    FPos: TPoint;
    FTime: Integer;
    FDisbitmap: TBitmap;
    fBackColor : TalphaColor;
    public
    destructor Destroy; override;
    property Bitmap : TBitmap read FDisbitmap;
    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;

    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 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;

    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;

    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;
    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;

    function ProcFrame: Boolean;
    var
    LineSize: Integer;
    LBackColorIndex: Integer;
    begin
    Result := False;
    With LDescriptor do
    begin
    LFrameWidth := Width;
    LFrameHeight := Height;
    FInterlace := ((Packedbit and $40) = $40);
    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);

    If LIsTransparent then
    begin
    LLocalPalette[LBackColorIndex].A := alphaTransparent;
    end;

    Result := True;
    end;

    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;

    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
    Stream.Read(FInitialCodeSize, 1);
    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);
    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;
    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 = 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 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;

    Repeat
    PLine := Data.GetScanline(Row);
    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;

    procedure RenderFrame(const Index : integer; const aFrames : array of TGifFrameItem; const aDisplay : TBitmap);
    var
    I, First, Last: Integer;
    begin
    Last := Index;
    First := Max(0, Last);
    aDisplay.Clear(aFrames[Index].fBackColor);
    while First > 0 do
    begin
    if (fScreenWidth = aFrames[First].Bitmap.Width) and (fScreenHeight = aFrames[First].Bitmap.Height) then
    begin
    if (aFrames[First].FDisposalMethod = GIF_DISPOSAL_BACKGROUND) and (First First) then
    begin
    // Restore background color
    aDisplay.ClearRect(TRectF.Create(aFrames[i].FPos.X, aFrames[i].FPos.Y,
    aFrames[i].FPos.X + aFrames[i].Bitmap.Width,
    aFrames[i].FPos.Y + aFrames[i].Bitmap.Height),
    aFrames[i].fBackColor);
    end;
    GIF_DISPOSAL_PREVIOUS: ; // Do nothing – previous state is already on screen
    end;
    end;
    MergeBitmap(aFrames[Index].Bitmap, aDisplay, aFrames[Index].Bitmap.Bounds, aFrames[Index].FPos.X, aFrames[Index].FPos.Y);
    end;

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

    Stream.Position := 0;
    Stream.Read(FHeader, SizeOf(FHeader));

    {$IFDEF BIGENDIAN}
    with FHeader do
    begin
    ScreenWidth := LEtoN(ScreenWidth);
    ScreenHeight := LEtoN(ScreenHeight);
    end;
    {$ENDIF}
    if (FHeader.Packedbit and $80) = $80 then
    begin
    ColorTableSize := FHeader.Packedbit and 7 + 1;
    ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
    end;
    if not ProcHeader then
    Exit;

    FrameIndex := 0;
    SetLength(LFrames, 0);
    while True do
    begin
    LLocalPalette := nil;
    Repeat
    Introducer := ReadAndProcBlock(Stream);
    until (Introducer in [$2C, $3B]);
    if Introducer = $3B then
    Break;

    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 (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;
    LFrame := TGifFrameItem.Create;
    LFrame.FTime := 10 * LGraphicsCtrlExt.DelayTime;
    LFrame.FDisbitmap := TBitmap.Create(LFrameWidth, LFrameHeight);
    LFrame.FPos := Point(LDescriptor.Left, LDescriptor.Top);
    LFrame.FDisposalMethod := 7 and (LGraphicsCtrlExt.Packedbit shr 2);
    if not ReadScanLine(Stream, @LScanLineBuf[0]) then
    Exit;
    if not WriteScanLine(LFrame.FDisbitmap, @LScanLineBuf[0]) then
    Exit;
    if LGraphCtrlExt then
    begin
    LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) 0;
    If LIsTransparent then
    LBC := LGraphicsCtrlExt.ColorIndex
    else
    LBC := FBackgroundColorIndex;
    end
    else
    LBC := FBackgroundColorIndex;
    LFrame.fBackColor := LLocalPalette[LBC].Color;
    Inc(FrameIndex);
    SetLength(LFrames, FrameIndex);
    LFrames[FrameIndex - 1] := LFrame;
    end;
    SetLength(rendered, Length(LFrames));
    for I := 0 to Length(LFrames) – 1 do
    begin
    tmp := TBitmap.Create(FScreenWidth, FScreenHeight);
    RenderFrame(I, LFrames, tmp);
    rendered[i] := tmp;
    end;
    for I := 0 to Length(LFrames) – 1 do
    begin
    LFrames[i].Bitmap.Assign(rendered[i]);
    FreeAndNil(rendered[i]);
    AFrameList.Add(LFrames[i]);
    end;

    Result := True;
    finally
    LLocalPalette := nil;
    LScanLineBuf := nil;
    rendered := nil;
    LFrames := 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;

    end.

  3. Karu Kaarigar说:

    This was very useful. But this code only reads and draws animated GIF. But I want to create animated GIF using FirMonkey. Can you please help me by updating this code so that animated GIF can be created? Thank you!

    这非常有用。 但是这段代码只能读取和绘制动画GIF。 但我想使用FireMonkey创建动画GIF。 您能否通过更新此代码来帮助我,以便创建动画GIF? 谢谢!

  4. Pingback引用通告: 如何检测GIF动画? - 4Find

发表评论

电子邮件地址不会被公开。

您可以使用这些HTML标签和属性: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>

你必须启用JavaScript