unit AnimeGif01;

interface
uses
  // Стандартные юниты
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  ActiveX, Dialogs, ExtCtrls,
  // Юниты GDI+
  GDIPAPI, GDIPOBJ;
// ==========================================================================
//  21.06.2014
//  Для обработчиков событий "Изменилось значение счетчика повторов GIF"
type TonCountDown = procedure (const LoopCount : integer) of object;

// 15.06.2014
type TTimeArr  = array[0..65535] of integer;
     TPTimeArr = ^TTimeArr;

// 15.06.2014     
type TAnimeGif = class(TObject)
  private
    //--------------------------------
    fApplication : TApplication;
    //--------------------------------
    fFileName    : string;            // Имя загруженного файла
    fGDbmp       : TGPBitmap;         // GPBitmap загрухенного *.GIF
    fGDw, fGDh   : cardinal;          // Габариты загрухенного GPBitmap
    fFrCount     : cardinal;          // Количество фреймов в загруженном GIF
    fPrCount     : cardinal;          // Количество property в загруженном GIF
    fLoopCount   : word;              // Число повторов GIF анимации
    //--------------------------------
    fFdBufSize   : cardinal;          // Память в байтах буфера FrameDelay
    fPFdBuf      : PPropertyItem;     // pointer на буфер FrameDelay
    fPTimeArr    : TPTimeArr;         // pointer на массив значений FrameDelay
    fDelayGif    : integer;           // Gif Время экспозиции отдельного кадра
    //--------------------------------
    fDelayAdd  : integer;             // Add Время экспозиции отдельного кадра
    fIncrm     : boolean;             // Инкрементный режим наложения кадров
    fZoom      : double;              // Масштабный коэффициент
    fIMode     : TInterpolationMode;  // Режим интерполяции при масштабировании
    fColor     : TColor;              // Цвет очистки Image
    //--------------------------------
    fCycle     : boolean;             // Флаг - циклическое повторение анимации
    fRun       : boolean;             // Флаг - анимация работает
    //--------------------------------
    fonCountDown : TonCountDown;      // Для подключения обработчика CountDown
    //--------------------------------
    function  GetFrTime(Ind : integer) : integer;
    function  GetFrameDelay(RqFrameNum : integer) : integer;
    procedure FreeFrameDelay();
    function  CreateTimeArr() : boolean;
    procedure LookEventsAndSleep();
    function  GetLoopCount()  : boolean;
    function  ColorToTGPColor (RqColor : TColor) : TGPColor;
    //--------------------------------
  public
    //--------------------------------
    // Установка InterpolationMode по сквознову индексу
    procedure   SetIMode(RqModeIndex : integer);
    // Загрузить GIF файл в GDI+ BitMap
    function    LoadGifFile (RqOpenDialog : TOpenDialog) : boolean;
    // Отмасштабировать GIF по RqH, RqW и отобразить RqImg
    procedure   ShowScaledGif(RqImg : TImage; RqH, RqW  : cardinal);
    // Пропорционально fZoom отмасштабировать GIF и отобразить RqImg
    procedure   ShowZoomGif(RqImg : TImage);
    // Построение и прорисовка пропорционально отмасштабированного
    // изображения, которое следует вписать в габариты RqTrW, RqTrH
    procedure   ShowThumbnailImage(RqImg : TImage; RqTrW, RqTrH : integer);
    // Создать объект
    constructor Create(Application : TApplication);
    // Ликвидировать объект
    procedure   Free();
    //--------------------------------
    // Получить ссылку на загруженный GDI+ BitMap
    property GDbmp    : TGPBitmap read fGDbmp;
    // Получить ширину загруженного GDI+ BitMap
    property GDw      : cardinal  read fGDw;
    // Получить высоту загруженного GDI+ BitMap
    property GDh      : cardinal  read fGDh;
    // Получить число кадров загруженного GDI+ BitMap
    property FrCount  : cardinal  read fFrCount;
    // Получить число повторов GIF анимации
    property LoopCount  : word    read fLoopCount;
    // Получить время (msec) показа кадра с индексом Ind
    property FrTime[Ind : integer] : integer   read  GetFrTime;
    // Получить или установить режим циклического показа кадров
    property Cycle    : boolean   read fCycle  write fCycle;
    // Получить или установить режим работает показ кадров
    property Run      : boolean   read fRun    write fRun;
    // Получить или установить масштаб кадров
    property Zoom     : double    read fZoom   write fZoom;
    // Получить или установить даполнительное время показа каждого кадра
    property DelayAdd : integer   read fDelayAdd write fDelayAdd;
    // Получить или установить инкрементный режим наложения кадров
    property Incrm    : boolean   read fIncrm   write fIncrm;
    // Получить текущую моду интерполированя
    property IMode    : TInterpolationMode  read fIMode;
    // Цвет очистки Image
    property Color    : TColor read fColor write fColor;
    //  Для обработчиков событий "Изменилось значение счетчика повторов GIF"
    property onCountDown : TonCountDown read fonCountDown write fonCountDown;
end;

// ==========================================================================
implementation
// ==========================================================================
// --------------------------------------------------------------------------
// 15.06.2014
constructor TAnimeGif.Create(Application : TApplication);
begin
  inherited Create();
  fApplication := Application;
  // -------------------------------------
  fFdBufSize   := 0;
  fPFdBuf    := nil;
  // -------------------------------------
  fIMode       := InterpolationModeDefault;
  fZoom        := 1;
  fDelayAdd    := 0;
  fIncrm       := False;
  fCycle       := False;
  fRun         := False;
  fColor       := clBtnFace;
  // -------------------------------------
  fonCountDown := nil;
end;

// --------------------------------------------------------------------------
// 15.06.2014
procedure TAnimeGif.Free();
begin
  FreeFrameDelay();
  if Assigned (fGDbmp) then fGDbmp.Free;
  inherited Free();
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Установка InterpolationMode по сквознову индексу
procedure TAnimeGif.SetIMode(RqModeIndex : integer);
begin
  case RqModeIndex of
  0 : fIMode := InterpolationModeDefault;
  1 : fIMode := InterpolationModeLowQuality;
  2 : fIMode := InterpolationModeHighQuality;
  3 : fIMode := InterpolationModeBilinear;
  4 : fIMode := InterpolationModeBicubic;
  5 : fIMode := InterpolationModeNearestNeighbor;
  6 : fIMode := InterpolationModeHighQualityBilinear;
  7 : fIMode := InterpolationModeHighQualityBicubic;
  else fIMode := InterpolationModeDefault;
  end;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Обслуживание property FrTime
function  TAnimeGif.GetFrTime(Ind : integer) : integer;
begin
   Result := 0;
   if Ind < 0 then Exit;
   if (fFdBufSize > 0)   and
      (fPTimeArr <> nil) and
      (Cardinal(Ind) < fFrCount)   and
      (Ind >= 0)
    then Result := (fPTimeArr^[Ind] * 10);
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Просматривать во время задерхки фрейма текущие события
procedure TAnimeGif.LookEventsAndSleep();
const TimeStep  = 200;                    // Шаг просмотра текущих событий
var   Delay     : integer;
      StepCount : integer;
begin
  Delay := (fDelayGif * 10) + fDelayAdd;
  if Delay <= 0
  then begin
    fApplication.ProcessMessages;
    Sleep(1);
  end
  else begin
    StepCount := Delay div TimeStep;
    while StepCount > 0 do
    begin
      fApplication.ProcessMessages;
      Sleep(TimeStep);
      Delay := Delay - TimeStep;
      StepCount := StepCount - 1;
    end;
    if Delay > 0
    then begin
       fApplication.ProcessMessages;
       Sleep(Delay);
    end;
  end;
end;

// --------------------------------------------------------------------------

function TAnimeGif.ColorToTGPColor (RqColor : TColor) : TGPColor;
type TRGB = record
     RI : byte;  // Канал R или nIndex функции GetSysColor
     G  : byte;  // Канал G
     B  : byte;  // Канал B
     S  : byte;  // Если $FF то SysColor
end;
var  PC : ^TRGB;
     SC : TRGB;
begin
    PC := Addr(RqColor);
    if PC^.S = 0
    then Result := MakeColor(255, PC^.RI, PC^.G, PC^.B)
    else begin
      SC := TRGB(GetSysColor(Integer(PC^.RI)));
      Result := MakeColor(255, SC.RI, SC.G, SC.B);
    end;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Отмасштабировать GIF по RqH, RqW и отобразить RqImg
procedure TAnimeGif.ShowScaledGif(RqImg     : TImage;
                                  RqH, RqW  : cardinal);
var WGraph        : TGPGraphics;
    WBrush        : TGPSolidBrush;
    GPColor       : TGPColor;         // Цвет очистки Image
    LoopCountDown : integer;
    Ind           : integer;
begin
   if not Assigned(fGDbmp) then Exit;

   // Преобразовать TColor в TGPColor
   GPColor := ColorToTGPColor(fColor);
   // Подготовить объект TGPSolidBrush
   WBrush := TGPSolidBrush.Create(GPColor);

   // Подготовить целевой Bitmap
   with RqImg.Picture.Bitmap
   do begin
      PixelFormat := pf24bit;
      Height := RqH;
      Width  := RqW;
   end;
   LoopCountDown := fLoopCount;
   // Вызов внешнего обработчика "Счетчик повторов"
   if Assigned(fonCountDown) then fonCountDown(LoopCountDown);
   // Связать WGraph с буферным RqImg
   WGraph := TGPGraphics.Create(RqImg.Picture.Bitmap.Canvas.Handle);
   WGraph.SetInterpolationMode(fIMode);
   // Отображение фреймов GIF в запрошенном RqImg
   if fFrCount > 0
   then begin
     repeat
        for Ind := 0 to fFrCount - 1 do
        begin
          // Очистить RqImg
          if not fIncrm
          then WGraph.FillRectangle(WBrush, 0,0, RqW, RqH);
          // Установить очередной кадр (фрейм)
          fGDbmp.SelectActiveFrame(FrameDimensionTime, Ind);
          // DrawImage to RqImg
          WGraph.DrawImage(fGDbmp, 0,0, RqW, RqH);
          // Немедленно обновить изображение
          RqImg.Repaint;
          // Получить время показа текущего фрейма
          fDelayGif := GetFrameDelay(Ind);
          // Сканировать текущие события на компонентах и выполнить задержку
          LookEventsAndSleep();
          // Проверить запрос завершения показа GIF
          if not fRun then Break;
        end;
        // Проверить запрос цикличности показа GIF
        if (not fCycle)
        then begin
            // Выход по счетчику повторов
            LoopCountDown := LoopCountDown - 1;
            if LoopCountDown < 0 then Break
            else if Assigned(fonCountDown)
                 then fonCountDown(LoopCountDown);
        end;
     until (not fRun);
   end;
   // Освободить ресурсы
   WBrush.Free;
   WGraph.Free;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Пропорционально fZoom отмасштабировать GIF и отобразить RqImg
procedure TAnimeGif.ShowZoomGif(RqImg : TImage);
var ZmH, ZmW  : cardinal;
begin
   ZmH  := Round(fGDh * fZoom);
   ZmW  := Round(fGDw * fZoom);
   ShowScaledGif(RqImg, ZmH, ZmW);
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Построение и прорисовка пропорционально отмасштабированного
// изображения, которое следует вписать в габариты RqTrW, RqTrH
procedure TAnimeGif.ShowThumbnailImage(RqImg : TImage;
                                       RqTrW, RqTrH : integer);
var WGraph   : TGPGraphics;
    TrW, TrH : cardinal;
    WCount   : cardinal;
begin
   if not Assigned(fGDbmp)     then Exit;
   if (fGDw < 1) or (fGDh < 1) then Exit;
   // Построение габаритов Image для пропорционального
   // размещения в запрошенном окне RqTrW, RqTrH
   TrW := RqTrW;
   TrH := Round(fGDh * TrW / fGDw);
   if  (TrH > cardinal(RqTrH))
   then begin
      TrH := cardinal(RqTrH);                          
      TrW := Round(fGDw * TrH / fGDh);
   end;
   // Подготовка Bitmap габаритов отмасштабированного Image
   with RqImg.Picture.Bitmap
   do begin
     PixelFormat := pf24bit;
     Height := TrH;
     Width  := TrW;
   end;
   // Выборка эскиза и его отображение
   WCount := fGDbmp.GetFrameCount(FrameDimensionTime);
   if WCount > 0
   then begin
      fGDbmp.SelectActiveFrame(FrameDimensionTime, 0);
      WGraph := TGPGraphics.Create(RqImg.Picture.Bitmap.Canvas.Handle);
      WGraph.SetInterpolationMode(InterpolationModeBicubic);
      WGraph.DrawImage(fGDbmp, 0,0, TrW, TrH);
      WGraph.Free;
   end;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Выборка времени задержки для фрейма с номером RqFrameNum
function TAnimeGif.GetFrameDelay(RqFrameNum : integer) : integer;
begin
    if (fFdBufSize > 0) and (fPTimeArr <> nil)
    then Result := fPTimeArr^[RqFrameNum]
    else Result := 0;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Освободить буфера задержек фреймов
procedure TAnimeGif.FreeFrameDelay();
begin
   if (fFdBufSize > 0) and (fPFdBuf <> nil)
   then begin
      try
         FreeMem(fPFdBuf, fFdBufSize);
      finally
         fPFdBuf    := nil;    // pointer на буфер FrameDelay
         fFdBufSize := 0;      // Память в байтах буфера FrameDelay
      end;
   end;
end;

// --------------------------------------------------------------------------
// 15.06.2014
// Создать массив задержек фреймов
function TAnimeGif.CreateTimeArr() : boolean;
var RqItem    : PropertyItem;
begin
   Result     := False;
   fPTimeArr  := nil;
   // Освободить старый буфер FrameDelay
   FreeFrameDelay();
   // Получить счетчик свойств
   fPrCount := fGDbmp.GetPropertyCount;
   if (fPrCount > 0) and (fGDbmp.GetLastStatus = Ok)
   then begin
      //
      fFdBufSize := fGDbmp.GetPropertyItemSize(PropertyTagFrameDelay);
      if (fFdBufSize > 0) and (fGDbmp.GetLastStatus = Ok)
      then begin
        try
           // Получить память под буфер массива
           GetMem(fPFdBuf, fFdBufSize);
        except
           fPFdBuf    := nil;
           fFdBufSize := 0;
        end;
        // Заполнить буфер
        if fPFdBuf <> nil
        then begin
           fGDbmp.GetPropertyItem(PropertyTagFrameDelay, fFdBufSize, fPFdBuf);
           if (fGDbmp.GetLastStatus = Ok)
           then begin
              // Скопировать из буфера заголовок PropertyItem
              RqItem := fPFdBuf^;
              if (RqItem.value <> nil) and
                 (RqItem.type_ = PropertyTagTypeLong)
              then begin
                 // Перетипизировать в массив задержек фреймов
                 // область значений в буфере
                 fPTimeArr := TPTimeArr(RqItem.value);
                 Result := True;
              end;
           end;
        end;
      end;
   end;
end;

// --------------------------------------------------------------------------
// 21.06.2014
// {$OPTIMIZATION OFF}
// Получить значение счетчика повторов анимации
function TAnimeGif.GetLoopCount() : boolean;
var  Item    : PropertyItem;
     BufSize   : cardinal;
     PBUF      : PPropertyItem;
     pValue    : ^word;
begin
   Result      := False;
   fLoopCount  := 0;
   PBUF        := nil;
   // Получить счетчик свойств
   fPrCount := fGDbmp.GetPropertyCount;
   if (fPrCount > 0) and (fGDbmp.GetLastStatus = Ok)
   then begin
      BufSize := fGDbmp.GetPropertyItemSize(PropertyTagLoopCount);
      if BufSize < 1 then Exit;
      try
        GetMem(PBUF, BufSize);
        fGDbmp.GetPropertyItem(PropertyTagLoopCount, BufSize, PBUF);
        if (fGDbmp.GetLastStatus = Ok)
        then begin
            // Скопировать из буфера заголовок PropertyItem
            Item := PBUF^;
            if (Item.value <> nil) and (Item.type_ = PropertyTagTypeShort)
            then begin
               // Сохранить значение счетчика повторов
               pValue := Item.value;
               fLoopCount := pValue^;
               Result := True;
            end;
        end;
       finally
         if (PBUF <> nil) and (BufSize > 0)
         then FreeMem(PBUF, BufSize);
       end;
   end;
end;
// {$OPTIMIZATION ON}

// --------------------------------------------------------------------------
// 15.06.2014
// Загрузить GIF файл в GDI+ BitMap
function TAnimeGif.LoadGifFile(RqOpenDialog : TOpenDialog) : boolean;
begin
 Result := False;
 if RqOpenDialog.Execute
 then begin
    fFileName := RqOpenDialog.FileName;
    if Assigned(fGDbmp)
    then begin
       fGDbmp.Free;
       fGDbmp := nil;
    end;
    try
       // Вариант с прямой загрузкой в GDbmp
       fGDbmp := TGPBitmap.Create(fFileName);
       // Габариты загруженного TGPBitmap
       fGDw := fGDbmp.GetWidth;
       fGDh := fGDbmp.GetHeight;
       fFrCount := fGDbmp.GetFrameCount(FrameDimensionTime);
       if fFrCount > 0
       then begin
          GetLoopCount();
          CreateTimeArr();
          Result := True;
       end;
    except
       fFileName := '';
    end;
 end;
end;

// ==========================================================================
// ==========================================================================
end.
