• 0
Вадим Смоленский

Обработка анимированных 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.

 

Поделиться сообщением


Ссылка на сообщение
Поделиться на другие сайты

2 ответа на этот вопрос

  • 3

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

  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

Поделиться сообщением


Ссылка на сообщение
Поделиться на другие сайты
  • 0

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

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

Поделиться сообщением


Ссылка на сообщение
Поделиться на другие сайты

Для публикации сообщений создайте учётную запись или авторизуйтесь

Вы должны быть пользователем, чтобы оставить комментарий

Создать учетную запись

Зарегистрируйте новую учётную запись в нашем сообществе. Это очень просто!

Регистрация нового пользователя

Войти

Уже есть аккаунт? Войти в систему.

Войти

  • Похожий контент

    • От FREEFAR
      Всем привет.
      Есть такое событие TakePhotoFromLibraryAction. Но вызов его дает возможность загрузить только фото.
      А как же получить доступ к файлу типа GIF ну или к видео?
      Неужели свои писать контейнер читая расшаренную папку с фото?
    • От ENERGY
      Привет. 
      Очень нужно мнение профессионалов FMX.
      Нужно создать анимированный контрол - как на гифке .
      По кругу ходит точка, которую можно перемещать. Также должен меняться цвет градиента (теплый или холодный цвета).
      Как думаете возможно ли создать такое контрол в FMX, если да то с чего лучше начать.
      Если брать векторную графику, рисуем этот круг, то как затем его деформировать. И что делать с другими элементами, - волной например. Дорисовать ее в виде Bitmap ?
      Посоветуйте пожалуйста.  
       
    • От denprox
      Доброго времени суток! Есть у кого ни будь пример того, как в RunTime нарисовать путь, по которому потом сможет двигаться объект ? 
      Я смог найти только видео:
      Tutorial: TPathAnimation in FireMonkey XE6
       
    • От Дмитрий Потапов
      Так, допустим, создал красивый стиль, но мало его просто нарисовать, программы могут обладать красивыми анимациями, вот в чем собственно вопрос:
      Как сделать анимированную кнопку например?
      Четыре состояния
      1. обычное 2. выделенное 3. нажатое 4. заблокированное (например на этом компоненте как сделать хотя бы плавное изменение цвета, а еще лучше попробовать сделать увеличение текста на кнопке)
    • От Martifan
      доброго времени сутки 
      подскажите пожалуйста как запустить GIF файл? чтобы анимацию показывала
      заранее спасибо
       
    • От 97mik
      Как сделать переход при выборе пункта в ListBox?
      И можно ли при этом будет вернутся свайпом слева направо?
       
    • От Kantrobac
      Здравствуйте, недавно приступил к изучению обезьянки, тк необходимо реализовать следующее: есть поле датчиков 30 штук, расположенных квадратом. Над ними проводят объект который меняет их магнитное поле, всё это записывается в двухмерный массив(т.е. в одной строчке(один датчик) будут 0 пока над датчиком не пролетит объект), необходимо визуализировать этот процесс. Решил использовать Plane, на которой закрепил 30 Cube(Рис 1). По задумке столбик должен расти при изменении значения в массиве: 
      float mas[3][3] = {{1,0,0},{0,1,0},{0,0,1}}; void __fastcall TForm3D1::Form3DCreate(TObject *Sender) { FloatAnimation1->Parent = Cube1; FloatAnimation1->PropertyName = "Scale.Y"; //FloatAnimation1->StopValue = 1; FloatAnimation1->Duration = 1; FloatAnimation1->AnimationType = TAnimationType::atIn; FloatAnimation1->Interpolation = TInterpolationType::itLinear; FloatAnimation1->StartFromCurrent = true; FloatAnimation2->Parent = Cube2; FloatAnimation2->PropertyName = "Scale.Y"; //FloatAnimation2->StopValue = 1; FloatAnimation2->Duration = 1; FloatAnimation2->AnimationType = TAnimationType::atIn; FloatAnimation2->Interpolation = TInterpolationType::itLinear; FloatAnimation2->StartFromCurrent = true; FloatAnimation3->Parent = Cube3; FloatAnimation3->PropertyName = "Scale.Y"; //FloatAnimation3->StopValue = 1; FloatAnimation3->Duration = 1; FloatAnimation3->AnimationType = TAnimationType::atIn; FloatAnimation3->Interpolation = TInterpolationType::itLinear; FloatAnimation3->StartFromCurrent = true; } void __fastcall TForm3D1::Button1Click(TObject *Sender) { for (int i = 0; i < 3; i++) { Form3D1->resizecube(i); } } void __fastcall TForm3D1::resizecube(int a) { FloatAnimation1->StopValue = mas[a][0]; FloatAnimation1->Start(); FloatAnimation2->StopValue = mas[a][1]; FloatAnimation2->Start(); FloatAnimation3->StopValue = mas[a][2]; FloatAnimation3->Start(); // ShowMessage(""); } Сделал пример для простого массива. Проблема в том, что если закоментить  ShowMessage(""); то отображается только последняя итерация. Подскажите как сделать так чтобы итерации выводились последовательно, друг за другом. Спасибо 

    • От DirtyBorov
      За ранее прошу простить если не в ту ветку. Вопрос двоякий и анимация и жесты.
      Нужно реализовать анимацию, таким образом, что бы она постепенно останавливалась. Вот например есть 10 картинок, надо их пальцем прокручивать. Но так, чтоб они постепенно останавливались. Причем картинки небольшие, сразу на экране могут быть 3 картинки.  Как бы лента из картинок. Картинок может быть много 100+. Стоит ли копать в сторону анимации? Не будет ли тормозить на слабеньком телефоне?
      Посоветуйте куда копать - анимация, Box2D?
    • От brunnengi
      Здравствуйте.
      Где можно посмотреть пример работы компонента TBitmapListAnimation?
    • От brunnengi
      Здравствуйте.
      Создал пяти секундный анимированный эффект в Abobe After Effects. 
      Сохранил в PNG формате с прозрачностью, по кадрам. Всего вышло 120 кадров.
      Через что можно создать в FMX Desktop приложение анимацию из последовательности этих кадров/файлов?
      Подскажите пожалуйста.
  • Последние посетители   0 пользователей онлайн

    Ни одного зарегистрированного пользователя не просматривает данную страницу