Ir al contenido



Foto

Formato de imagen GIF


  • Por favor identifícate para responder
19 respuestas en este tema

#1 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 05 febrero 2010 - 11:36

El formato gráfico GIF es de sobra conocido. Puede albergar varias imágenes y soportar pequeñas animaciones. Es un formato comprimido basado en el algoritmo LZW sin pérdida de calidad pero sólo hasta 256 colores.

Gif es un verdadero protocolo de transmisión de gráficos o un formato de archivo orientado a stream soportando entrelazado.

Todo archivo Gif comienza con una cabecera identificadora, con una firma (GIF 87a  ó GIF 89a) y los datos del descriptor de pantalla. Seguidamente pero opcional, tendríamos la paleta global y los datos de las imágenes. Los datos se empaquetan en bloques de longitud máxima 255 bytes. Cada bloque tiene una estructura idéntica que comienza con un Byte en el que se guarda el tamaño de los datos que lo siguen. Existen Extensiones adicionales que no son de imagen propiamente dicha como Graphic Control Extension, Comment Extension, Plain Text Extensión y Application Extension.

Cada extensión comienza con un Byte identificador de extensión (carácter '!'), un byte de firma o tipo de extensión, los datos en bloques (con el formato antes descrito) y un bloque terminador nulo (un Byte 0). Más información aquí.

Publico una clase que he escrito para el manejo de los archivos GIF escrita en C++ y en delphi. Dicha clase reúne casi todas las especificaciones GIF 89a y una Extensión de aplicación que permite el Loop de las imágenes (NETSCAPE 2.0). De forma que podremos visualizar o crear pequeñas animaciones GIF.

Las funciones básicas de la clase son:

Constructor por defecto, desde Un archivo o desde un Bitmap
LoadFromFile:  Carga un archivo
SaveToFile:  Guarda un archive.
IsOk:  True si el gif no causó errores.
GetBitmapCount:  Obtiene el número de imágenes de un Gif
IsFormat:  Estudia si un archivo tiene cabecera Gif válida
GetBitmap:  Devuelve un Bitmap según un índice
GetGraphicBlock:  Devuelve un puntero a una estructura Gráfica (TGraphicBlock)
AddGraphicBlock:  Añade un TGraphicBlock a la lista del Gif
SetGraphicBlock
InsertGraphicBlock
DeleteGraphicBlock

En la versión Builder C++ tenemos el operador:
operator Graphics::TBitmap*(); Con el que conseguimos el casting a la primera imagen almacenada.

La clase guarda una lista de TGraphicBlock. Cada uno guarda una imagen y datos adicionales de la misma. Esos datos se utilizaran para realizar nuestro visor gif. De ellos Bitmap representa la imagen o fotograma actual y  DelayTime el tiempo que se mostrará esa imagen:
 


delphi
  1. TGraphicBlock = record
  2.   Bitmap:                TBitmap; // La Imagen
  3.   Method:                BYTE;    // Método de borrado de la Imagen:
  4.                                   //  1: Sin acción específica
  5.                                   //  2: No se quita la imagen
  6.                                   //  3: Se restaura al color de fondo
  7.                                   //  4: Se restaura al estado previo el área sobrescrita
  8.   UserInput:            BYTE;    // bool
  9.   DelayTime:            WORD;    // Tiempo de retardo para cambiar la Imagen
  10.   Transparency:          BYTE;    // bool
  11.   TransparentColorIndex: BYTE;
  12.   Left:                  DWORD;   // Posición del Bitmap en la Ventana gráfica
  13.   Top:                  DWORD;
  14. end; PGraphicBlock = ^TGraphicBlock;


cpp
  1. struct TGraphicBlock{
  2.   Graphics::TBitmap* Bitmap;      // La Imagen
  3.   BYTE              Method;      // Método de borrado de la Imagen:
  4.                                   //  1: Sin acción específica
  5.                                   //  2: No se quita la imagen
  6.                                   //  3: Se restaura al color de fondo
  7.                                   //  4: Se restaura al estado previo el área sobrescrita
  8.   BYTE              UserInput;    // bool
  9.   WORD              DelayTime;    // Tiempo de retardo para cambiar la Imagen
  10.   BYTE              Transparency; // bool
  11.   BYTE              TransparentColorIndex;
  12.   DWORD             Left;        // Posición del Bitmap en la Ventana gráfica
  13.   DWORD             Top;
  14. };

Miembros importantes de la clase son:

Interlace:  Indica si la imagen es entrelazada
Loop:        Indica si las imágenes harán un loop al reproducirlas.
BackgroundColor: El color de fondo
Comments:  Un TStringList con una lista de cadenas con los comentarios del GIF (Extensiones de comentario).

Como ejemplo de utilización, publico dos aplicaciones:
1.- Una pequeña aplicación para visualizar y guardar imágenes en formato GIF sin animación.
2.- Otra aplicación que visualiza animaciones GIF. Como ejemplo, esta aplicación guarda un gif en un archivo mediante una lista de fotogramas de un Gif previamente leído. Es un simple ejemplo de como crear un gif animado desde bitmaps.
Los ejemplos son tremendamente sencillos, pero se pueden complicar un poco más para crear una pequeña aplicación que nos permita crear nuestras propias animaciones GIF


Espero que este código sea de utilidad para las aplicaciones tanto delphi como Builder o al menos aclare algo sobre el formato Gif.

 

 

¡ATENCIÓN!      La clase ha sido revisada y actualizada para las versiones delphi + berlin, Builder + Berlin y Lazarus v1.8.4. Los enlaces de estas versiones los tenéis AQUÍ

 

 

Saludos.

Archivos adjuntos


  • 0

#2 enecumene

enecumene

    Webmaster

  • Administrador
  • 7.408 mensajes
  • LocationRepública Dominicana

Escrito 05 febrero 2010 - 11:41

:o :-#, ¡¡ excelente aporte amigo !! :o (y), muchas gracias escafandra.
  • 0

#3 egostar

egostar

    missing my father, I love my mother.

  • Administrador
  • 14.003 mensajes
  • LocationMéxico

Escrito 05 febrero 2010 - 11:44

Muchas gracias amigo escafandra, siempre interesantes tus aportaciones :)

Salud OS
  • 0

#4 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 05 febrero 2010 - 11:47

Muchas gracias a vosotros por el intereis que mostrais.  :D

Saludos.
  • 0

#5 Caral

Caral

    Advanced Member

  • Administrador
  • 4.241 mensajes
  • LocationCosta Rica

Escrito 05 febrero 2010 - 11:48

Hola
Que bueno, muy interesante, lo voy a tratar de probar. (y)
Muchas gracias por el aporte. (y) (b)
Saludos
  • 0

#6 seoane

seoane

    Advanced Member

  • Administrador
  • 1.249 mensajes
  • LocationEspaña

Escrito 05 febrero 2010 - 02:28

Impresionante  (y)
  • 0

#7 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.262 mensajes
  • LocationArgentina

Escrito 05 febrero 2010 - 06:58

Me dejas con los ojos abiertos y pequeñito de la envidia, ¿hay algo que no sepas :D :)?

¡Gracias por compartir tus conocimientos y tus habilidades!

Saludos,
  • 0

#8 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 05 febrero 2010 - 07:34

...Que bueno, muy interesante, lo voy a tratar de probar. (y)...

No lo dudes, si sigues bien los ejemplos verás que es fácil e intuitivo. No dejes de exponer tus pegas o de descubrir algún bug.

Impresionante  (y)

Gracias a tí maestro.

¿hay algo que no sepas :D :)?

Me queda casi todo por saber, amigo.



Gracias a todos vosotros.  :D

Saludos.
  • 0

#9 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 01 marzo 2010 - 03:46

La clase TGif ha sido actualizada con motivo de la realización de un componente visualizador de Este tipo de gráficos y animaciones. La actualización básicamente mejora el problema de las transparencias en las imágenes Gif y arregla un bug en el color de fondo de las mismas.

La nueva versión de TGif, tanto para C/C++ como para delphi se encuentra en este hilo.

Saludos.


  • 0

#10 creedelcam

creedelcam

    Newbie

  • Miembros
  • Pip
  • 1 mensajes

Escrito 08 julio 2010 - 02:37

Hola Escafandra,
Estoy trabajando en C++ Builder 6 con imagenes. Mi problema es que cuando agrego un "Image" a mi proyecto e intento cargar una imagen de tipo *.gif, a traves de la propiedad "Picture" no lo consigo pues dicho formato no lo reconoce (unicamente puedo escoger entre archivos *.jpg, *.bmp, *.ico, entre otros), favor indicarme que debo hacer.
Tengo el Borland C++ Builder version 6.0 (Build 10.160) he visto que otros usuarios pueden hacerlo con la misma version, por favor ayudenme,
saludos!
  • 0

#11 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 08 julio 2010 - 03:37

Bienvenido al foro, creedelcam.

La clase que expongo, no permite trabajar directamente como quieres. No se deriva de nada que conozcas de la VCL, pero tiene procedimientos para compatibilizarse con ella. Seguro que lo que te permitirá cargar un gif y luego convertirlo a un TBitmap. Baja los adjuntos de ejemplo.

En concreto mira este código:
 


cpp
  1. // Leer un gif de un archivo y asignarlo a un TImage
  2. TGIF gif;
  3. gif.LoadFromFile(OpenDialog1->FileName);
  4. Image1->Picture->Bitmap->Assign(gif);


cpp
  1. // Guardar la imagen de un TImage en formato Gif
  2. TGIF Gif(Image1->Picture->Bitmap);
  3. Gif.SaveToFile(SaveDialog1->FileName);

Si descargas el código adjunto, encontrarás mas utilidades de la clase, incluso animaciones Gif.

Por otro lado, puedes descargarte un componente, TGifViewer que escribí para crear rápidamente un visor de gráficos GIF. Aquí encontrarás una actualización de la clase TGif y un programa de ejemplo que te demostrará cómo utilizar ese componente.

Seguro que te resulta de utilidad.

Saludos.


  • 0

#12 cHackAll

cHackAll

    Advanced Member

  • Administrador
  • 598 mensajes

Escrito 18 enero 2011 - 09:12

Muy interesante escafandra!, con tu permiso comparto un ejemplo utilizando APIs;



delphi
  1. // . . .
  2.  
  3.   repeat
  4.     hCanvas := GetDC(hDlg);
  5.     GdipCreateFromHDC(hCanvas, hGraphics);
  6.     GdipFillRectangleI(hGraphics, hBrush, Rect.Top, Rect.Left, Rect.Right, Rect.Bottom);
  7.     GdipDrawImageRectI(hGraphics, hImage, Rect.Top, Rect.Left, Rect.Right, Rect.Bottom);
  8.     GdipDeleteGraphics(hGraphics);
  9.     ReleaseDC(hDlg, hCanvas);
  10.     if Frames > 1 then
  11.     begin
  12.       GdipImageSelectActiveFrame(hImage, FrameDimensionTime, Index);
  13.       Index := (Index + 1) mod Frames;
  14.     end;
  15.     Sleep(Elapse[Index] * 10);
  16.   until not IsWindow(hDlg);
  17.  
  18. // . . .



Saludos

Archivos adjuntos


  • 0

#13 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 18 enero 2011 - 09:30

Muy interesante escafandra!, con tu permiso comparto un ejemplo utilizando APIs;

Por supuesto, amigo....

...mmm GDIplus  :D

El código de la clase que publique lo escribí bastante antes de que apareciera GDIplus, en los tiempos del DOS. Lo actualicé con motivo de este hilo pues me pareció muy instructivo.
El uso de la API del GDIplus lo hace mucho mas sencillo pero más anónimo y menos portable.

En cualquier caso es inhabitable echar mano del GDIplus con el cual he jugado con provecho. (y)



Saludos.
  • 0

#14 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 19 junio 2011 - 10:23

...Y ahora también en Lazarus

Pues descargué e instale Lazarus y para empezar a jugar y a raíz de un hilo, adapté la  Clase TGif a este entorno.

La funcionalidad de clase es la misma que las versiones para delphi y C/C++, recordar que además proporcionar soporte para de  visualizar imágenes Gif estáticas, lo hace también para animaciones. Puede guardar archivos gif y proporciona soporte para crear  nuestras propias animaciones.

He encontrado algún contratiempo al trabajar con TBitmaps en Lazarus. En un principio pensé que sería similar a delphi o Builder  pero me topé con un impedimento a la hora de usar TBitmap.ScanLine pués, no existe. Parece ser que se debe a la incompatibilidad  con los Device Independent Bitmap de Windows. Así que tuve que escribir una clase para conseguir suplantar esa funcionalidad a una  velocidad aceptable. Dicha clase, TBitmapStream se deriva de TMemoryStream y básicamente se trata de un mapa en memoria de un  fichero .bmp.

Espero que sea de utilidad para, los cada vez mas numerosos, amantes de Lazarus.

Saludos.

PD: Por un problema puntual, no puedo subir los adjuntos por el momento.


  • 0

#15 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 19 junio 2011 - 10:25

Por problemas para subir archivos, publico el código completo:



delphi
  1. {*******************************************************************************
  2.  
  3.   Objetivo  : CARGA, DESCOMPRESION Y COMPRESIÓN DE FICHEROS GIF.
  4.   Autor      : escafandra 2011.
  5.   Compilador : Lazarus
  6.  
  7. *******************************************************************************}
  8.  
  9. unit Gif;
  10.  
  11. {$MODE Delphi}
  12.  
  13. interface
  14. uses
  15.   Windows, Classes, Graphics, IntfGraphics, SysUtils, Math;
  16.  
  17. const  NO_CODE    =  -1;
  18. const  GIFSIG    =  'GIF89a';
  19. const  LARGESTCODE = 4095;
  20. const  TABLESIZE  = 5003;
  21. const  NLIN        = 10;    //Numero de lineas procesadas para informar del progreso
  22.  
  23. // Líneas de comienzo del entrelazado 4 pasadas:
  24. StarTable: array[0..3] of WORD  = (0, 4, 2, 1);
  25. // Incrementos del entrelazado para cada línea de comienzo (líneas siguientes):
  26. IncTable:  array[0..3] of WORD  = (8, 8, 4, 2);
  27.  
  28. wordmasktable: array[0..15] of WORD =
  29.               ($0000, $0001, $0003, $0007,
  30.               $000F, $001F, $003F, $007F,
  31.               $00FF, $01FF, $03FF, $07FF,
  32.               $0FFF, $1FFF, $3FFF, $7FFF);
  33.  
  34. type
  35.  
  36. {$ALIGN 1}
  37.  
  38. GIFHEADER = record
  39.   // Header 3 BYTES:  "GIF"
  40.   // Version 3 BYTES: "87a", "89a"
  41.   signature: array[0..5] of CHAR;  // GIF87a ó GIF89a
  42.  
  43.   // Logical Screen Descriptor:
  44.   ScreenWidth, ScreenHeight: WORD;
  45.   flags, background, aspect: BYTE;
  46. end;  PGIFHEADER = ^GIFHEADER;
  47.  
  48. IMAGEBLOCK = record
  49.   Introducer:BYTE ; //',' 
  50.   left, top, width, height: WORD;
  51.   flags: BYTE;
  52. end; PIMAGEBLOCK = ^IMAGEBLOCK;
  53.  
  54. GRAPHIC_CONTROL_EXTENSION = record
  55.   Introducer, Label_E, BlockSize, flags: BYTE;
  56.   DelayTime: WORD;
  57.   TransparentColorIndex, Terminator: BYTE;
  58. end; PGRAPHIC_CONTROL_EXTENSION = ^GRAPHIC_CONTROL_EXTENSION;
  59.  
  60. NETSCAPE_EXTENSION = record
  61.   Introducer:            BYTE;  // '!'
  62.   Label_E:                BYTE;  // 0xFF
  63.   BlockSize:              BYTE;  // 11
  64.   AppId:  array[0..7] of CHAR;  // "NETSCAPE"
  65.   AppCode: array[0..2] of CHAR;  // "2.0"
  66.   SubBlockSize:          BYTE;  // 3
  67.   Data1:                  BYTE;  // 1
  68.   LoopIterator:          WORD;  // 0
  69.   Terminator:            BYTE;  // 0
  70. end; PNETSCAPE_EXTENSION = ^NETSCAPE_EXTENSION;
  71.  
  72. COMMENT_EXTENSION_HEADER = record
  73.   Introducer: BYTE;              // '!'
  74.   Label_E:    BYTE;              // 0xFE
  75.   BlockSize:  BYTE;              //
  76.   Comment: array[0..0] of CHAR;  // Cadena de comentario ASCII/Z
  77. end; PCOMMENT_EXTENSION_HEADER = ^COMMENT_EXTENSION_HEADER;
  78.  
  79. {$ALIGN OFF}
  80.  
  81. TGraphicBlock = record
  82.   Bitmap:                TBitmap;  // La Imagen
  83.   Method:                BYTE;    // Metodo de borrado de la Imagen:
  84.                                   //  1: Sin accion espec´´ifica
  85.                                   //  2: No se quita la imagen
  86.                                   //  3: Se restaura al color de fondo
  87.                                   //  4: Se restaura al estado previo el area sobreescrita
  88.   UserInput:            BYTE;    // bool
  89.   DelayTime:            WORD;    // Tiempo de retardo para cambiar la Imagen
  90.   Transparency:          BYTE;    // bool
  91.   TransparentColorIndex: BYTE;
  92.   Left:                  DWORD;    // Posición del Bitmap en la Ventana gráfica
  93.   Top:                  DWORD;
  94. end; PGraphicBlock = ^TGraphicBlock;
  95.  
  96. TRGBTable = record
  97.   Red:  BYTE;
  98.   Green: BYTE;
  99.   Blue:  BYTE;
  100. end; PRGBTable = ^TRGBTable;
  101. TRGBArray = array[0..0] of TRGBTable;
  102. PRGBArray = ^TRGBArray;
  103.  
  104. BMPFILEHEADER = record
  105.  
  106.   // Un fichero.bmp comienza con una cabeceraBMP como esta.
  107.   // Sigue con la paleta indexada en RGB, justo detras de la cabecera.
  108.   // Termina con la imagen en mapa de bits comenzando de abajo a arriba.
  109.   // Si el mapa es de 24 bits no se guarda la paleta
  110.  
  111.   Signature:      WORD;    // BM  4D42
  112.   SizeFile:      DWORD;  // Tamaño del fichero.bmp
  113.   Reserved1:      WORD;    // Reservado, debe ser cero
  114.   Reserved2:      WORD;    // Reservado, debe ser cero
  115.   OffBits:        DWORD;  // Desplazamiento del comienzo de la imagen
  116.   SizeOfBMIH:    DWORD;  // Tamaño de BITMAPINFOHEADER, debe ser 40
  117.   Width:          DWORD;  // Nº Maximo de Columnas
  118.   Height:        DWORD;  // Nº Maximo de Filas
  119.   BitPlanes:      WORD;    // Nº Planos de bit debe ser 1
  120.   BitCount:      WORD;    // Nº de bits por pixel (1, 4, 8, o 24)
  121.   Compression:    DWORD;  // Tipo de compresion (0=none, 1=RLE-8, 2=RLE-4)
  122.   SizeImage:      DWORD;  // Tamaño de la imagen en bytes (padding incluido)
  123.   XPelsPerMeter:  DWORD;  // Resolucion horizontal en pixels por metro (unreliable)
  124.   YPelsPerMeter:  DWORD;  // Resolucion vertical en pixels por metro (unreliable)
  125.   ClrUsed:        DWORD;  // Numero de colores de la imagen, o cero
  126.   ClrImportant:  DWORD;  // Numero de colores importantes, o cero
  127.   Palette:        DWORD;
  128. end;
  129. PBMPFILEHEADER = ^BMPFILEHEADER;
  130.  
  131.  
  132. TBitmapStream = class (TMemoryStream)
  133.   public
  134.   constructor Create();
  135.   constructor CreateFromData(Width, Height, BitCount: integer);
  136.  
  137.   function  GetWidth(): LONG;
  138.   function  GetHeight(): LONG;
  139.   function  GetBitCount(): WORD;
  140.   function  GetBits(): Pointer;
  141.   function  GetPalette(): Pointer;
  142.   function  ScanLine(Line: DWORD): Pointer;
  143.   procedure GetRGBTableColors(Colors: PBYTE);
  144.   procedure SetRGBTableColors(Colors: PBYTE);
  145.   procedure InitFromData(Width, Height, BitCount: DWORD);
  146. end;
  147.  
  148.  
  149. ////////////////////////////////////////////////////////////////////////////////
  150. // Definicion de la clase manejadora de ficheros GIF.
  151. ////////////////////////////////////////////////////////////////////////////////
  152. TGIF = class
  153.   public
  154.   Interlace:  boolean;      // Indica si la imagen es entrelazada
  155.   Loop:        boolean;      // Indica si las imagenes harán un loop al reproducirlas.
  156.   BackgroundColor: TColor;  // Color de fondo
  157.   Comments:    TStringList;
  158.  
  159.   constructor  Create;
  160.   constructor  CreateFromBitmap(Bitmap: TBitmap);
  161.   constructor  CreateFromFile(const FileName: String);
  162.   destructor  Destroy; override;
  163.  
  164.   procedure    LoadFromFile(FileName: String);
  165.   function    LoadFromBitmap(Bitmap: TBitmap): boolean;
  166.   procedure    SaveToFile(FileName: String);
  167.   function    Load(const FileName: String): boolean;  // Carga un GIF.
  168.   function    Write(const FileName: String): boolean; // Escribe un GIF.
  169.   function    GetBitmapCount(): integer;              // Devuelve el nº de imagenes en lista
  170.   function    IsOk(): boolean;                        //
  171.   function    IsFormat(const FileName: String): boolean; // consulta la cabecera GIF de un archivo
  172.   function    GetBitmap(n: integer = 0): TBitmap;    // Devuelve la imagen n de la lista
  173.   function    GetGraphicBlock(n: integer): PGraphicBlock;
  174.   procedure    AddGraphicBlock(GB: TGraphicBlock);
  175.   procedure    SetGraphicBlock(n: integer; GB: PGraphicBlock);
  176.   procedure    InsertGraphicBlock(n: integer; GB: PGraphicBlock);
  177.   procedure    DeleteGraphicBlock(n: integer);
  178.  
  179.   protected
  180.   FBmpStream:  TBitmapStream;
  181.   FBitmap:    TBitmap;  // TBitmap con la imegen actualmente leida
  182.   FListBitmap: TList;
  183.   DefPalette:  array of TRGBTable; // PRGBArray;
  184.   DefNColors:  integer;
  185.  
  186.   function    UnpackGif(): boolean;  // Desempaqueta la imagen
  187.   function    SkipExtension(Offset: LongInt): LongInt; // Salta una extension
  188.  
  189.   function    UnZipImage(pGifLZW: PBYTE; bits, width, height, flags: integer): LongInt;
  190.  
  191.   function    WriteGif(hFile: integer): LongInt;
  192.   function    WriteGifHeader(hFile: integer): LongInt;
  193.   function    WriteIBlockHeader(hFile: integer; GBlock: PGraphicBlock): LongInt;
  194.   function    WriteImage(hFile: integer; GBlock: PGraphicBlock): LongInt;
  195.   function    Flush(hFile: integer; N: BYTE): LongInt;
  196.   function    WriteCode(hFile: integer; Code: integer): LongInt;
  197.  
  198.   function    ZipImage(hFile: integer; Bitmap: TBitmap): LongInt;
  199.   function    WriteLoopNetscape(hFile: integer): LongInt;
  200.   function    WriteComment(hFile: integer; Comment: PCHAR): LongInt;
  201.   function    GetCommentExtension(Offset: LongInt): LongInt;
  202.   function    CmpPalette(Palette: pointer; nColors: integer): boolean;
  203.   procedure    InitTable(MinCodeSize: integer);
  204.  
  205.   private
  206.   Ok:          boolean;
  207.  
  208.   // Datos de lectura:
  209.   GifBuffer:  PBYTE;    // Buffer que contiene todo el fichero GIF leido
  210.   GifBufferSize: DWORD;  // Tamaño del archivo.gif leido
  211.  
  212.   // Datos de escritura:
  213.   OldCode:    array of WORD; // PAWord;
  214.   CurrentCode: array of WORD; //PAWord;
  215.   NewCode:    array of BYTE; //PAByte;
  216.   CodeBuffer:  array of BYTE; //PAByte;
  217.  
  218.   CodeSize:    WORD;
  219.   ClearCode:  WORD;
  220.   EofCode:    WORD;
  221.   BitOffset:  DWORD;
  222.   ByteOffset:  DWORD;
  223.   BitsLeft:    DWORD;
  224.   MaxCode:    WORD;
  225.   FreeCode:    WORD;
  226.  
  227.   procedure    BuildWBuffers();
  228.   procedure    ClearListBitmap();
  229. end;
  230.  
  231. //---------------------------------------------------------------------------
  232.  
  233. const
  234. nl: NETSCAPE_EXTENSION = (Introducer: BYTE('!'); Label_E: $FF; BlockSize: 11;
  235.                           AppId: 'NETSCAPE'; AppCode: '2.0'; SubBlockSize: 3;
  236.                           Data1: 1; LoopIterator: 0; Terminator: 0);
  237.  
  238.  
  239. implementation
  240.  
  241.  
  242. //------------------------------------------------------------------------------
  243. constructor TBitmapStream.Create();
  244. begin
  245.   inherited Create;
  246. end;
  247.  
  248. constructor TBitmapStream.CreateFromData(Width, Height, BitCount: integer);
  249. begin
  250.   inherited Create;
  251.   InitFromData(Width, Height, BitCount);
  252. end;
  253.  
  254. procedure TBitmapStream.InitFromData(Width, Height, BitCount: DWORD);
  255. var
  256.   SizeImage, ColorCount, SizeFile: DWORD;
  257. begin
  258.   Clear;
  259.   if BitCount <=  4 then BitCount:=  4
  260.   else if BitCount <=  8 then BitCount:=  8
  261.   else if BitCount <= 15 then BitCount:= 15
  262.   else if BitCount <= 16 then BitCount:= 16
  263.   else if BitCount <= 24 then BitCount:= 24
  264.   else if BitCount <= 32 then BitCount:= 32;
  265.  
  266.   SizeImage:= ((Width * BitCount + 31) div 32) * 4 * Height;
  267.   ColorCount:= (1 shl BitCount);
  268.   SizeFile:= sizeof(BMPFILEHEADER) + (ColorCount-1) * 4 + SizeImage;
  269.   SetSize(SizeFile);
  270.  
  271. //  FillChar(Memory^, sizeof(BMPFILEHEADER), 0);
  272.   PBMPFILEHEADER(Memory)^.Signature:= $4D42; // 'BM'
  273.   PBMPFILEHEADER(Memory)^.SizeFile:= SizeFile;
  274.   PBMPFILEHEADER(Memory)^.Width:= Width;
  275.   PBMPFILEHEADER(Memory)^.Height:= Height;
  276.   PBMPFILEHEADER(Memory)^.BitCount:= BitCount;
  277.   PBMPFILEHEADER(Memory)^.OffBits:= sizeof(BMPFILEHEADER) + (ColorCount-1) * 4;
  278.   PBMPFILEHEADER(Memory)^.SizeOfBMIH:= 40;
  279.   PBMPFILEHEADER(Memory)^.SizeImage:= SizeImage;
  280.   PBMPFILEHEADER(Memory)^.ClrUsed:= ColorCount;
  281.   PBMPFILEHEADER(Memory)^.ClrImportant:= 0;  // ColorCount;
  282.   PBMPFILEHEADER(Memory)^.Reserved1:= 0;      // Reservado, debe ser cero
  283.   PBMPFILEHEADER(Memory)^.Reserved2:= 0;      // Reservado, debe ser cero
  284.   PBMPFILEHEADER(Memory)^.BitPlanes:= 1;
  285.   PBMPFILEHEADER(Memory)^.Compression:= 0;    // Tipo de compresion (0=none, 1=RLE-8, 2=RLE-4)
  286.   PBMPFILEHEADER(Memory)^.XPelsPerMeter:= 0;  // Resolucion horizontal en pixels por metro (unreliable)
  287.   PBMPFILEHEADER(Memory)^.YPelsPerMeter:= 0;  // Resolucion vertical en pixels por metro (unreliable)
  288. end;
  289.  
  290. procedure TBitmapStream.GetRGBTableColors(Colors: PBYTE);
  291. var
  292.   i, nColors: cardinal;
  293.   Palette: PBYTE;
  294. begin
  295.   Palette:= GetPalette;
  296.   if (GetBitCount < 24) and (Colors <> nil) then
  297.   begin
  298.     nColors := (1 shl GetBitCount);
  299.     for i:=0 to nColors - 1 do
  300.     begin
  301.       (Colors + 2)^:= (Palette + 0)^;    // Blue
  302.       (Colors + 1)^:= (Palette + 1)^;    // Green
  303.       (Colors + 0)^:= (Palette + 2)^;    // Red
  304.       inc(Palette, 4);
  305.       inc(Colors, 3);
  306.     end;
  307.   end;
  308. end;
  309.  
  310. procedure TBitmapStream.SetRGBTableColors(Colors: PBYTE);
  311. var
  312.   i, nColors: cardinal;
  313.   Palette: PBYTE;
  314. begin
  315.   Palette:= GetPalette;
  316.   if (GetBitCount < 24) and (Colors <> nil) then
  317.   begin
  318.     nColors := (1 shl GetBitCount);
  319.     for i:=0 to nColors - 1 do
  320.     begin
  321.       (Palette + 0)^ := (Colors + 2)^;    // Blue
  322.       (Palette + 1)^ := (Colors + 1)^;    // Green
  323.       (Palette + 2)^ := (Colors + 0)^;    // Red
  324.       (Palette + 3)^ := 0;
  325.       inc(Palette, 4);
  326.       inc(Colors, 3);
  327.     end;
  328.   end;
  329. end;
  330.  
  331. function TBitmapStream.GetBitCount(): WORD;
  332. begin
  333.   Result := PBMPFILEHEADER(Memory)^.BitCount;
  334. end;
  335.  
  336. function TBitmapStream.GetWidth(): LONG;
  337. begin
  338. //  Result:= PLONG(Memory+18)^;
  339.   Result:= PBMPFILEHEADER(Memory)^.Width;
  340. end;
  341.  
  342. function TBitmapStream.GetHeight(): LONG;
  343. begin
  344. //  Result:= PLONG(Memory+22)^;
  345.   Result:= PBMPFILEHEADER(Memory)^.Height;
  346. end;
  347.  
  348. function TBitmapStream.GetPalette(): Pointer;
  349. begin
  350.   Result:= Memory + sizeof(BMPFILEHEADER) - 4;
  351. end;
  352.  
  353. function TBitmapStream.GetBits(): Pointer;
  354. begin
  355. //  Result:= Memory + PDWORD(Memory+10)^;
  356.   Result:= Memory + PBMPFILEHEADER(Memory)^.OffBits;
  357. end;
  358.  
  359. function  TBitmapStream.ScanLine(Line: DWORD): Pointer;
  360. var
  361.   SizeLine: DWORD;
  362. begin
  363.   SizeLine:= ((GetWidth * GetBitCount + 31) div 32) * 4;
  364.   Result:= Memory + PBMPFILEHEADER(Memory)^.OffBits + (int64(GetHeight) - 1 - Line) * SizeLine;
  365. end;
  366.  
  367. //------------------------------------------------------------------------------
  368. //  El constructor por defecto.
  369. constructor TGIF.Create;
  370. begin
  371.   FListBitmap:= TList.Create;
  372.   FBitmap:= TBitmap.Create;
  373.   FBmpStream:= TBitmapStream.Create;
  374.   Comments:= TStringList.Create;
  375. end;
  376.  
  377. //------------------------------------------------------------------------------
  378. //  El constructor desde un Bitmap
  379. constructor TGIF.CreateFromBitmap(Bitmap: TBitmap);
  380. begin
  381.   FListBitmap:= TList.Create;
  382.   FBmpStream:= TBitmapStream.Create;
  383.   FBitmap:= TBitmap.Create;
  384.   FBitmap.HandleType:= bmDIB; //bmDDB; //;
  385.   Comments:= TStringList.Create;
  386.   LoadFromBitmap(Bitmap);
  387. end;
  388.  
  389. function TGIF.LoadFromBitmap(Bitmap: TBitmap): boolean;
  390. var
  391.   GB: TGraphicBlock;
  392. begin
  393.   Result:= false;
  394.   if Bitmap.PixelFormat > pf8bit then exit;
  395.   Interlace:= FALSE;
  396.   Loop:= FALSE;
  397.   Ok:= TRUE;
  398.   FBitmap.Assign(Bitmap);
  399.   //ZeroMemory(@GB, sizeof(TGraphicBlock));
  400.   FillChar(GB, sizeof(TGraphicBlock), 0);
  401.   GB.Bitmap:= FBitmap;
  402.   AddGraphicBlock(GB);
  403. end;
  404.  
  405. //------------------------------------------------------------------------------
  406. //  El constructor desde un archivo
  407. constructor TGIF.CreateFromFile(const FileName: string);
  408. begin
  409.   Interlace:= FALSE;
  410.   Loop:= FALSE;
  411.   Ok:= TRUE;
  412.   FListBitmap:= TList.Create;
  413.   FBitmap:= TBitmap.Create;
  414.   FBmpStream:= TBitmapStream.Create;
  415.   Comments:= TStringList.Create;
  416.   if FileName <> '' then
  417.     Ok:= Load(FileName);
  418. end;
  419.  
  420.  
  421. //------------------------------------------------------------------------------
  422. //  El destructor.
  423. destructor TGIF.Destroy;
  424. begin
  425.   ClearListBitmap;
  426.   FListBitmap.Destroy;
  427.   FBitmap.Destroy;
  428.   FBmpStream.Destroy;
  429.   Comments.Destroy;
  430. end;
  431.  
  432. //------------------------------------------------------------------------------
  433. // Vacía los fotogramas
  434. procedure TGIF.ClearListBitmap();
  435. var
  436.   n:  integer;
  437.   GB: PGraphicBlock;
  438. begin
  439.   for n:= 0 to FListBitmap.Count-1 do
  440.   begin
  441.       GB:= PGraphicBlock(FListBitmap.Items[n]);
  442.       GB.Bitmap.Destroy;
  443.       FreeMem(GB);
  444.   end;
  445.   FListBitmap.Clear;
  446. end;
  447.  
  448. //------------------------------------------------------------------------------
  449. // Carga un GIF.
  450. procedure TGIF.LoadFromFile(FileName: String);
  451. begin
  452.   Load(FileName);
  453. end;
  454.  
  455. //------------------------------------------------------------------------------
  456. // Guarda un GIF.
  457. procedure TGIF.SaveToFile(FileName: String);
  458. begin
  459.   Write(FileName);
  460. end;
  461.  
  462. //------------------------------------------------------------------------------
  463. // Carga un GIF.
  464. function TGIF.Load(const FileName: String): boolean;
  465. var
  466.   FileHandle : Integer;
  467. begin
  468.   Loop:= FALSE;
  469.   Ok:= FALSE;
  470.   ClearListBitmap;
  471.   Comments.Clear();
  472.  
  473.   FileHandle:= FileOpen(FileName, fmOpenRead {or fmShareDenyNone});
  474.   if  FileHandle <> -1 then
  475.   begin
  476.     // Mira el tamaño del GIF.
  477.     // Reserva memoria para el fichero.
  478.     GifBufferSize := FileSeek(FileHandle,0,2);
  479.     FileSeek(FileHandle,0,0);
  480.     GifBuffer:= AllocMem(GifBufferSize);
  481.     if FileRead(FileHandle, GifBuffer^, GifBufferSize) = integer(GifBufferSize) then
  482.     begin
  483.         Ok:= UnpackGif();
  484.         if Ok <> TRUE then
  485.           FreeMem(GifBuffer);
  486.     end;
  487.     FileClose(FileHandle);
  488.   end;
  489.   Result:= Ok;
  490. end;
  491.  
  492. //------------------------------------------------------------------------------
  493. // Escribe un GIF.
  494. function TGIF.Write(const FileName: String): boolean;
  495. var
  496.   FileHandle : Integer;
  497. begin
  498.   Result:= FALSE;
  499.   if FListBitmap <> nil then
  500.   begin
  501.     if FListBitmap.Count > 0 then
  502.     begin
  503.       FileHandle:= FileCreate(FileName);
  504.       if  FileHandle <> -1 then
  505.       begin
  506.           WriteGif(FileHandle);
  507.           FileClose(FileHandle);
  508.           Result:= TRUE;
  509.       end;
  510.     end;
  511.   end;
  512. end;
  513.  
  514. //------------------------------------------------------------------------------
  515. // Devuelve el nº de imagenes en lista
  516. function TGIF.GetBitmapCount(): integer;
  517. begin
  518.   Result:= FListBitmap.Count; // Devuelve el nº de imagenes en lista
  519. end;
  520.  
  521. //------------------------------------------------------------------------------
  522. // Devuelve si tenemos cargado un archivo válido sin errores
  523. function TGIF.IsOk(): boolean;
  524. begin
  525.   Result:= Ok;
  526. end;
  527.  
  528. //------------------------------------------------------------------------------
  529. // consulta la cabecera GIF de un archivo
  530. function TGIF.IsFormat(const FileName: String): boolean;
  531. var
  532.   FileHandle : Integer;
  533.   Cabecera:    GIFHEADER;
  534. begin
  535.   Result:= FALSE;
  536.   FileHandle:= FileOpen(FileName, fmOpenRead or fmShareDenyNone);
  537.   if (FileHandle <>-1) then
  538.   begin
  539.     FileRead(FileHandle, Cabecera, sizeof(Cabecera));
  540.     FileClose(FileHandle);
  541.     Result:= CompareMem(@Cabecera.signature[0], PCHAR(GIFSIG), 3);
  542.   end;
  543. end;
  544.  
  545. //------------------------------------------------------------------------------
  546. // Devuelve la imagen n de la lista
  547. function TGif.GetBitmap(n: integer = 0): TBitmap;
  548. begin
  549.   if Ok = TRUE then
  550.       Result:= (PGraphicBlock(FListBitmap.Items[n])).Bitmap
  551.   else
  552.       Result:= FBitmap;
  553. end;
  554.  
  555. //------------------------------------------------------------------------------
  556. // Devuelve un Bloque gráfico n de la lista
  557. function TGif.GetGraphicBlock(n: integer): PGraphicBlock;
  558. begin
  559.   Result:= PGraphicBlock(FListBitmap.Items[n]);
  560. end;
  561.  
  562. //------------------------------------------------------------------------------
  563. procedure TGif.AddGraphicBlock(GB: TGraphicBlock);
  564. var
  565.   pGB: PGraphicBlock;
  566. begin
  567.   GetMem(pGB, sizeof(TGraphicBlock));
  568.   pGB^:= GB;
  569.   pGB.Bitmap:= TBitmap.Create;
  570.   pGB.Bitmap.Assign(GB.Bitmap);
  571.   FListBitmap.Add(pGB);
  572. end;
  573.  
  574. //------------------------------------------------------------------------------
  575. procedure TGif.SetGraphicBlock(n: integer; GB: PGraphicBlock);
  576. begin
  577.   PGraphicBlock(FListBitmap.Items[n])^ := GB^;
  578.   PGraphicBlock(FListBitmap.Items[n]).Bitmap.Assign(GB.Bitmap);
  579. end;
  580.  
  581. //------------------------------------------------------------------------------
  582. procedure TGif.InsertGraphicBlock(n: integer; GB: PGraphicBlock);
  583. var
  584.   Item: PGraphicBlock;
  585. begin
  586.   GetMem(Item, sizeof(TGraphicBlock));
  587.   FListBitmap.Insert(n, Item);
  588.   SetGraphicBlock(n, GB);
  589. end;
  590.  
  591. //------------------------------------------------------------------------------
  592. procedure TGif.DeleteGraphicBlock(n: integer);
  593. begin
  594.   PGraphicBlock(FListBitmap.Items[n]).Bitmap.Free;
  595.   FListBitmap.Delete(n);
  596. end;
  597.  
  598. //------------------------------------------------------------------------------
  599. // Desempaqueta e interpreta un archivo GIF
  600. function TGif.UnpackGif(): boolean;
  601. var
  602.   ReadOff: DWORD;
  603.   gh: PGIFHEADER;
  604.   iblk: PIMAGEBLOCK;
  605.   GCE: PGRAPHIC_CONTROL_EXTENSION;
  606.   NL: PNETSCAPE_EXTENSION;
  607.   //CE: PCOMMENT_EXTENSION_HEADER;
  608.   Palette: PBYTE;
  609.   NumColors, BitCount, bits: integer;
  610.   nUnzipBytes: DWORD;
  611.   GB: TGraphicBlock;
  612.   AGifBuffer: PCHAR;
  613. begin
  614.   Result:= FALSE;
  615.   ReadOff:= 0;
  616.   Palette:= nil;
  617.   AGifBuffer:= PCHAR(GifBuffer);
  618.  
  619.   // Asegurarse de que es un Fichero GIF
  620.   gh:= PGIFHEADER(GifBuffer);
  621.   ReadOff:= ReadOff + sizeof(GIFHEADER);
  622.  
  623.   if CompareMem(@gh.signature[0], PCHAR(GIFSIG), 3) = TRUE then
  624.   begin
  625.     // Obtener las dimensiones de la pantalla
  626.     bits:= (gh.flags and $0007)+1;
  627.     BitCount:= (gh.flags and $0007)+1;
  628.     // Obtener el mapa de colores si existe uno
  629.     if (gh.flags and $80) = $80 then
  630.     begin
  631.       NumColors:= (1 shl BitCount);
  632.       Palette:= GifBuffer + ReadOff;
  633.       inc(ReadOff, 3*NumColors);
  634.       // Obtener el Background Color
  635.       BackgroundColor:= RGB((Palette + gh.background)^,
  636.                             (Palette + gh.background+1)^,
  637.                             (Palette + gh.background+2)^);
  638.     end else BackgroundColor:= 0;
  639.  
  640.     // Step through the blocks
  641.     // ZeroMemory(@GB, sizeof(TGraphicBlock));
  642.     FillChar(GB, sizeof(TGraphicBlock), 0);
  643.     while (AGifBuffer[ReadOff] = ',') or (AGifBuffer[ReadOff] = '!') or (AGifBuffer[ReadOff] = #0) do
  644.     begin
  645.       // si es un bloque de imagen
  646.       if AGifBuffer[ReadOff] = ',' then
  647.       begin
  648.           // Obtener el comienzo del bloque de imagen
  649.           iblk:= PIMAGEBLOCK(GifBuffer + ReadOff);
  650.           inc(ReadOff, sizeof(IMAGEBLOCK));
  651.           // Obtener el mapa local de colores si existe uno
  652.           if (iblk.flags and $80) = $80 then
  653.           begin
  654.             NumColors:= 1 shl ((iblk.flags and $0007)+1);
  655.             Palette:= GifBuffer + ReadOff;
  656.             inc(ReadOff, 3*NumColors);
  657.           end;
  658.           // Obtener si es entrelazado
  659.           Interlace:= ((iblk.flags and $40) = $40);
  660.  
  661.           // Obtener el tamaño del codigo inicial
  662.           bits:= (GifBuffer + ReadOff)^;
  663.           inc(ReadOff);
  664.           if bits = BYTE(-1{EOF}) then
  665.           begin
  666.             Result:= FALSE;
  667.             break;
  668.           end;
  669.  
  670.           // Memoria para el dibujo descomprimido.
  671.           if BitCount < 4 then BitCount:= 4;
  672.           FBmpStream.InitFromData(iblk.width, iblk.height, BitCount);
  673.  
  674.           // Coloco la paleta
  675.           FBmpStream.SetRGBTableColors(Palette);
  676.  
  677.           // Desempaqueta la imagen
  678.           nUnzipBytes:= UnZipImage(GifBuffer+ReadOff, bits, iblk.width, iblk.height, iblk.flags);
  679.           inc(ReadOff, nUnzipBytes);
  680.           GB.Bitmap:= FBitmap;
  681.           GB.Left  := iblk.left;
  682.           GB.Top  := iblk.top;
  683.           AddGraphicBlock(GB);
  684.           if nUnzipBytes <> 0 then continue;
  685.           Result:= TRUE;
  686.           break;
  687.       end
  688.       // En otro caso es una extension
  689.       else if AGifBuffer[ReadOff] = '!' then
  690.       begin
  691.         // ¿Es un Graphic Control Extension?
  692.         if AGifBuffer[ReadOff+1] = CHAR($F9) then
  693.         begin
  694.           GCE:= PGRAPHIC_CONTROL_EXTENSION(GifBuffer + ReadOff);
  695.           GB.Method:=      (GCE.flags shr 2) and 07;
  696.           GB.UserInput:=  (GCE.flags shr 1) and 01;
  697.           GB.Transparency:= GCE.flags and 01;
  698.           GB.DelayTime:=    GCE.DelayTime;
  699.           GB.TransparentColorIndex:= GCE.TransparentColorIndex;
  700.         end;
  701.         // ¿Es un NetscapeLoop?
  702.         NL:= PNETSCAPE_EXTENSION(GifBuffer + ReadOff);
  703.         Loop:= (Loop or CompareMem(NL, nl, sizeof(NETSCAPE_EXTENSION)-3));
  704.  
  705.         // ¿Es un comentario?
  706. //        CE:= PCOMMENT_EXTENSION_HEADER(DWORD(GifBuffer) + ReadOff);
  707. //        if CE.Label_E = $FE then
  708. //          Comment:= String(CE.Comment, CE.BlockSize);
  709.         GetCommentExtension(ReadOff);
  710.  
  711.         ReadOff:= SkipExtension(ReadOff);
  712.       end;
  713.     end;
  714.   end;
  715.   Result:= Ok;
  716. end;
  717.  
  718. //------------------------------------------------------------------------------
  719. // Salta una extension
  720. function TGIF.SkipExtension(Offset: LongInt): LongInt;
  721. var
  722.   AGifBuffer: PCHAR;
  723.   n: integer;
  724. begin
  725.   AGifBuffer:= PCHAR(GifBuffer);
  726.   if AGifBuffer[Offset] = '!' then
  727.   begin
  728.     inc(Offset, 2);
  729.     repeat
  730.       n:= integer(AGifBuffer[Offset]);
  731.       inc(Offset);
  732.       if n <> (-1){EOF} then
  733.         inc(Offset, n);
  734.     until (n = 0) or (n = -1{EOF});
  735.  
  736.   end;
  737.   Result:= Offset;
  738. end;
  739.  
  740. //------------------------------------------------------------------------------
  741. // Descomprime una Imagen Gif.
  742. function TGIF.UnZipImage(pGifLZW: PBYTE; bits, width, height, flags: integer): LongInt;
  743. var
  744.   GifLZW: PBYTE;
  745.   bits2: WORD;          // Bits plus 1
  746.   codesize: integer;    // Current Code size in bits
  747.   codesize2: integer;    // Next Code size
  748.   nextcode: integer;    // Next babailable table entry
  749.   thiscode: WORD;        // Code begin expanded
  750.   oldtoken: integer;    // last simbol decoded
  751.   currentcode: integer;  // Code just read
  752.   oldcode: integer;      // Code read before this one
  753.   bitsleft: integer;    // Number of bits left in *p
  754.   blocksize: integer;    // Bytes in next block
  755.   line: WORD;            // Nex line to write
  756.   NexByte: WORD;        // Nex byte to write
  757.   pass: WORD;            // Number of interlaced pictures
  758.   p: PBYTE;              // Pointer to current byte in read buffer
  759.   q: PBYTE;              // Pointer pass last byte in read buffer
  760.   b: array [0..255]of BYTE;      // Read buffer
  761.   u: PBYTE;                      // Stack pointer into firtscodestack
  762.   linebuffer:  array of BYTE;    // Place to store the current line
  763.   firtscodestack: array of BYTE; // Stack for firts code
  764.   lastcodestack: array of BYTE;  // Stack for previous code
  765.   codestack:  array of WORD;    // Stack for links
  766.   LinePixels: PByteArray;
  767.   X: integer;
  768.   Error: boolean;
  769. begin
  770.   Error:= FALSE;
  771.   GifLZW:= pGifLZW;
  772.   line:= 0;    // Next line to write
  773.   NexByte:= 0; // Next byte to write
  774.   pass:= 0;    // Number of interlaced pictures
  775.  
  776.   SetLength(firtscodestack, 4096); // Stack for firts code
  777.   SetLength(lastcodestack, 4096);  // Stack for previous code
  778.   SetLength(codestack, 4096);      // Stack for links
  779.   SetLength(linebuffer, width);
  780.  
  781.   p:= @b[0]; q:= @b[0];
  782.   bitsleft:= 8;
  783.  
  784.   // Si el bitCount esta en rango 2 a 8
  785.   if(bits >= 2) or (bits <= 8) then
  786.   begin
  787.     bits2    := (1 shl bits);
  788.     nextcode  := bits2 + 2;
  789.     codesize  := bits + 1;
  790.     codesize2 := (1 shl codesize);
  791.     oldcode  := NO_CODE;
  792.     oldtoken  := NO_CODE;
  793.     while TRUE do
  794.     begin
  795.       if bitsleft = 8 then
  796.       begin
  797.         inc(p);
  798.         if p >= q then
  799.         begin
  800.           blocksize:= GifLZW^;
  801.           inc(GifLZW);
  802.           if blocksize < 1 then
  803.           begin
  804.             Result:= 0;
  805.             Error:= TRUE;
  806.             break;
  807.           end else
  808.           begin
  809.             p:= @b[0];
  810.             q:= p + blocksize;
  811.             CopyMemory(@b[0], GifLZW, blocksize);
  812.             inc(GifLZW, blocksize);
  813.           end;
  814.         end;
  815.         bitsleft:= 0;
  816.       end;
  817.       thiscode:= p^;
  818.       currentcode:= codesize + bitsleft;
  819.       if currentcode <= 8 then
  820.       begin
  821.         p^ := (p^ shr codesize);
  822.         bitsleft:= currentcode;
  823.       end else
  824.       begin
  825.         inc(p);
  826.         if p >= q then
  827.         begin
  828.           blocksize:= GifLZW^;
  829.           inc(GifLZW);
  830.           if blocksize < 1 then
  831.           begin
  832.             Error:= TRUE;
  833.             Result:= 0;
  834.             break;
  835.           end else
  836.           begin
  837.             p:= @b[0];
  838.             q:= p + blocksize;
  839.             CopyMemory(@b[0], GifLZW, blocksize);
  840.             inc(GifLZW, blocksize);
  841.           end;
  842.         end;
  843.         thiscode:= thiscode or (p^ shl (8 - bitsleft));
  844.         if currentcode <= 16 then
  845.         begin
  846.             bitsleft:= currentcode - 8;
  847.             p^:= (p^ shr bitsleft);
  848.         end else
  849.         begin
  850.           inc(p);
  851.           if p >= q then
  852.           begin
  853.             blocksize:= GifLZW^;
  854.             inc(GifLZW);
  855.             if blocksize < 1 then
  856.             begin
  857.               Result:= 0;
  858.               Error:= TRUE;
  859.               break;
  860.             end else
  861.             begin
  862.               p:= @b[0];
  863.               q:= p + blocksize;
  864.               CopyMemory(@b[0], GifLZW, blocksize);
  865.               inc(GifLZW, blocksize);
  866.             end;
  867.           end;
  868.           thiscode:= thiscode or (p^ shl (16 - bitsleft));
  869.           bitsleft:= currentcode - 16;
  870.           p^:= (P^ shr bitsleft);
  871.         end;
  872.       end;
  873.  
  874.       thiscode:= thiscode and wordmasktable[codesize];
  875.       currentcode:= thiscode;
  876.  
  877.       if thiscode = (bits2+1) then  break; // encontrado EOI
  878.       if thiscode > nextcode then
  879.       begin
  880.         Result:= 0;
  881.         Error:= TRUE; // error("Codigo erroneo");
  882.         break;
  883.       end;
  884.  
  885.       if thiscode = bits2 then
  886.       begin
  887.         nextcode:= bits2 + 2;
  888.         codesize:= bits + 1;
  889.         codesize2:= 1 shl codesize;
  890.         oldcode:= NO_CODE;
  891.         oldtoken:= NO_CODE;
  892.         continue;
  893.       end;
  894.  
  895.       u:= PBYTE(firtscodestack);
  896.  
  897.       if thiscode = nextcode then
  898.       begin
  899.         if oldcode = NO_CODE then
  900.         begin
  901.           Result:= 0;
  902.           Error:= TRUE; // error("Codigo erroneo");
  903.           break;
  904.         end;
  905.         u^:= BYTE(oldtoken);
  906.         inc(u);
  907.         thiscode:= oldcode;
  908.       end;
  909.       while thiscode >= bits2 do
  910.       begin
  911.         u^:= lastcodestack[thiscode];
  912.         inc(u);
  913.         thiscode:= codestack[thiscode];
  914.       end;
  915.  
  916.       oldtoken:= thiscode;
  917.  
  918.       // Escribir los datos ya descomprimidos en linebuffer en el bitmap
  919.       while TRUE do
  920.       begin
  921.         linebuffer[NexByte]:= BYTE(thiscode);
  922.         inc(NexByte);
  923.         if NexByte >= width then
  924.         begin
  925.             // Escribir adaptando al formato del Bitmap
  926.             if FBmpStream.GetBitCount > 4 then
  927.               CopyMemory(FBmpStream.ScanLine(line), linebuffer, width)
  928.             else
  929.             // Es pf4bit
  930.             begin
  931.               LinePixels:= FBmpStream.ScanLine(line);
  932. //              for X:= 0 to (width shr 1) - 1 do
  933.               for X:= 0 to (width div 2) - 1 do
  934.                 LinePixels[X]:= (linebuffer[X*2] shl 4) or linebuffer[X*2+1];
  935.             end;
  936.             NexByte:= 0;
  937.  
  938.             // Chequea imagen entrelazada
  939.             if (flags and $40) = $40 then
  940.             begin
  941.               inc(line, IncTable[pass]);
  942.               if line >= height then
  943.               begin
  944.                 inc(pass);
  945.                 line:= StarTable[pass];
  946.               end;
  947.             end else inc(line);
  948.         end;
  949.         if u <= PBYTE(firtscodestack) then break;
  950.         dec(u);
  951.         thiscode:= u^;
  952.       end; // while TRUE 2º
  953.  
  954.       if (nextcode < 4096) and (oldcode <> NO_CODE) then
  955.       begin
  956.         codestack[nextcode]    := WORD(oldcode);
  957.         lastcodestack[nextcode] := BYTE(oldtoken);
  958.         inc(nextcode);
  959.         if(nextcode >= codesize2) and (codesize < 12) then
  960.         begin
  961.           inc(codesize);
  962.           codesize2:= 1 shl codesize;
  963.         end;
  964.       end;
  965.       oldcode:= currentcode;
  966.     end; // while TRUE 1º
  967.   end; // Si el bitCount esta en rango 2 a 8
  968.  
  969.   if Error = FALSE then
  970.   begin
  971.     Result:= GifLZW - pGifLZW + 1;
  972.     Ok:= TRUE;
  973.   end else
  974.   begin
  975.     Ok:= FALSE;
  976.     Result:= 0;
  977.   end;
  978.  
  979.   // Volcamos a FBitmap
  980.   FBitmap.LoadFromStream(FBMPStream);
  981.  
  982. end;  //AQUI FIN FUNCION


Por ser excesivamente largo sigo en el siguiente mensaje.

Saludos.
 
  • 0

#16 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 19 junio 2011 - 10:38

Continua la clase TGif para Lazarus.


delphi
  1. //------------------------------------------------------------------------------
  2. // Empaqueta y escribe un archivo GIF
  3. function TGIF.WriteGif(hFile: integer): LongInt;
  4. var
  5.   i: integer;
  6.   Terminator: CHAR;
  7. begin
  8.   BuildWBuffers;
  9.   // Cabecera del archivo GIF
  10.   Result:= WriteGifHeader(hFile);
  11.  
  12.   // Cuerpo: Cabeceras locales e Imágenes comprimidas
  13.   for i:= 0 to FListBitmap.Count-1 do
  14.       Result:= Result + WriteImage(hFile, PGraphicBlock(FListBitmap.Items[i]));
  15.  
  16.   // Escribo los comentarios
  17.   for i:= 0 to Comments.Count-1 do
  18.     WriteComment(hFile, PCHAR(Comments.Strings));
  19.  
  20.   // Escribir el terminador GIF
  21.   Terminator:= ';';
  22.   Result:= Result + FileWrite(hFile, Terminator, sizeof(CHAR));
  23. end;
  24.  
  25. //------------------------------------------------------------------------------
  26. // Escribe la cabecera GIF del archivo, el Logical Screen Descriptor
  27. // y la paleta global si procede
  28. function TGIF.WriteGifHeader(hFile: integer): LongInt;
  29. var
  30.   gh: GIFHEADER;
  31.   bits: WORD;
  32.   background: WORD;
  33. begin
  34.   Result:= 0;
  35.   FBMPStream.Position:= 0;
  36.   FBitmap.SaveToStream(FBMPStream);
  37.   bits  := FBMPStream.GetBitCount;
  38.   if bits > 8 then exit;
  39.  
  40.   background:= WORD(FBitmap.Canvas.Pixels[0, 0]);
  41.  
  42.   //ZeroMemory(@gh, sizeof(GIFHEADER));
  43.   FillChar(gh, sizeof(GIFHEADER), 0);
  44.   CopyMemory(@gh.signature[0], PCHAR(GIFSIG), 6);
  45.   gh.ScreenWidth  := WORD(FBitmap.Width);
  46.   gh.ScreenHeight := WORD(FBitmap.Height);
  47.   gh.background  := background;
  48.  
  49.   DefNColors := (1 shl bits);
  50.   SetLength(DefPalette, DefNColors);
  51.   FBMPStream.GetRGBTableColors(PBYTE(DefPalette));
  52.  
  53.   if(DefNColors = 0) then
  54.         gh.flags := WORD(((bits-1) and $07) shl 4)
  55.   else
  56.         gh.flags := WORD($80 or ((bits-1) shl 4) or ((bits-1) and $07));
  57.  
  58.   Result := FileWrite(hFile, gh, sizeof(GIFHEADER));
  59.   if(DefPalette <> nil) then
  60.     inc(Result, FileWrite(hFile, DefPalette[0], 3*DefNColors));
  61. end;
  62.  
  63. //------------------------------------------------------------------------------
  64. // Escribe el IMAGEBLOCK de una imagen
  65. // y su paleta local si la tiene, es decir, si es diferente de la Global
  66. function TGIF.WriteIBlockHeader(hFile: integer; GBlock: PGraphicBlock): LongInt;
  67. var
  68.   ib: IMAGEBLOCK;
  69.   bits: WORD;
  70.   ncolors: integer;
  71.   palette: array [0..255] of TRGBTable;
  72.   LocalPalette: boolean;
  73. begin
  74.   FBMPStream.Position:= 0;
  75.   GBlock.Bitmap.SaveToStream(FBMPStream);
  76.   bits  := FBMPStream.GetBitCount;
  77.  
  78.   //ZeroMemory(@ib, sizeof(IMAGEBLOCK));
  79.   FillChar(ib, sizeof(IMAGEBLOCK), 0);
  80.   ib.Introducer:= BYTE(',');
  81.   ib.left      := GBlock.Left;
  82.   ib.top      := GBlock.Top;
  83.   ib.width    := WORD(GBlock.Bitmap.Width);
  84.   ib.height    := WORD(GBlock.Bitmap.Height);
  85.   ncolors      := (1 shl bits);
  86.  
  87.  
  88.   //Obtengo la Paleta de la Imagen
  89.   FBMPStream.GetRGBTableColors(@palette[0]);
  90.  
  91.   // Si es igual a la global, no la considero.
  92.   LocalPalette:= TRUE;
  93.   if CmpPalette(@palette[0], ncolors) = TRUE then
  94.     LocalPalette := FALSE;
  95.  
  96.   // Colocar el flag de paleta local y la longitud de la misma.
  97.   if LocalPalette = FALSE then  ib.flags:= WORD(bits-1)
  98.   else                          ib.flags:= WORD(((bits-1) and $07) or $80);
  99.   if(Interlace)          then  ib.flags:= ib.flags or $40;
  100.  
  101.   // Escribo el IMAGEBLOCK de esta imagen
  102.   Result:= FileWrite(hFile, ib, sizeof(IMAGEBLOCK));
  103.  
  104.   // Si tenemos paleta local, la escribimos
  105.   if(LocalPalette = TRUE) then
  106.     inc(Result, FileWrite(hFile, DefPalette[0], 3*DefNColors));
  107. end;
  108.  
  109. //------------------------------------------------------------------------------
  110. // Escribe un Fotograma
  111. function TGIF.WriteImage(hFile: integer; GBlock: PGraphicBlock): LongInt;
  112. var
  113.   GCE:  GRAPHIC_CONTROL_EXTENSION;
  114. begin
  115.   // Escribir el Graphic Control Extension:
  116.   GCE.Introducer := BYTE('!');
  117.   GCE.Label_E    := $F9;
  118.   GCE.BlockSize  := 4;
  119.   GCE.flags      := (GBlock.Method shl 2) or (GBlock.UserInput shl 1) or GBlock.Transparency;
  120.   GCE.DelayTime  := GBlock.DelayTime;
  121.   GCE.TransparentColorIndex := GBlock.TransparentColorIndex;
  122.   GCE.Terminator := 0;
  123.   Result:= FileWrite(hFile, GCE, sizeof(GRAPHIC_CONTROL_EXTENSION));
  124.  
  125.   // Escribir el Image Block Header
  126.   inc(Result, WriteIBlockHeader(hFile, GBlock));
  127.  
  128.   // escribir la imagen comprimida
  129.   inc(Result, ZipImage(hFile, GBlock.Bitmap));
  130.   if Loop = TRUE then
  131.     inc(Result, WriteLoopNetscape(hFile));
  132. end;
  133.  
  134. //------------------------------------------------------------------------------
  135. // Escribe un Bloque en el archivo
  136. function TGIF.Flush(hFile: integer; N: BYTE): LongInt;
  137. begin
  138.   Result:= FileWrite(hFile, N, sizeof(BYTE)) +
  139.             FileWrite(hFile, CodeBuffer[0], N);
  140. end;
  141.  
  142. //------------------------------------------------------------------------------
  143. // Escribe los códigos comprimidos LZW y vuelca a disco cuando precisa
  144. function TGIF.WriteCode(hFile: integer; Code: integer): LongInt;
  145. var
  146.   Temp: DWORD;
  147. begin
  148.   Result:= 0;
  149.  
  150.   ByteOffset:= BitOffset shr 3;
  151.   BitsLeft  := BitOffset and 7;
  152.  
  153.   if(ByteOffset >= 254) then
  154.   begin
  155.     Result:= Flush(hFile, ByteOffset);
  156.     CodeBuffer[0]:= CodeBuffer[ByteOffset];
  157.     BitOffset    := BitsLeft;
  158.     ByteOffset  := 0;
  159.   end;
  160.  
  161.   if(BitsLeft > 0) then
  162.   begin
  163.     Temp:= (DWORD(code) shl BitsLeft) or CodeBuffer[ByteOffset];
  164.     CodeBuffer[ByteOffset]  := BYTE(Temp);
  165.     CodeBuffer[ByteOffset+1]:= BYTE(Temp shr 8);
  166.     CodeBuffer[ByteOffset+2]:= BYTE(Temp shr 16);
  167.   end else
  168.   begin
  169.     CodeBuffer[ByteOffset]  := BYTE(code);
  170.     CodeBuffer[ByteOffset+1]:= BYTE(code shr 8);
  171.   end;
  172.  
  173.   inc(BitOffset, CodeSize);
  174. end;
  175.  
  176. //------------------------------------------------------------------------------
  177. // Comprime una imagen en LZW
  178. function TGIF.ZipImage(hFile: integer; Bitmap: TBitmap): LongInt;
  179. var
  180.   MinCodeSize: WORD;
  181.   PrefixCode:WORD  ;
  182.   SuffixChar:WORD ;
  183.   hx,d: DWORD;
  184.   X,Y: integer;      // Coordenadas de pixel
  185.   XMax, YMax: integer;
  186.   pass: integer;    // peses en imagenes entrelazadas
  187.   LineBuffer: PByteArray;
  188. begin
  189.   FBMPStream.Position:= 0;
  190.   Bitmap.SaveToStream(FBMPStream);
  191.   MinCodeSize:= FBMPStream.GetBitCount;
  192.   X:=0; Y:=0;
  193.   pass:= 0;
  194.  
  195.   // Asegurarse de que el primer code size es legal
  196.   // Las imagenes monocromas tienen 2 bits en LZW compresion
  197.   if(MinCodeSize = 1) then  MinCodeSize := 2;
  198.   if(MinCodeSize >= 2) and (MinCodeSize <= 8) then
  199.   begin
  200.       // escribir el primer code size
  201.       Result:= FileWrite(hFile, MinCodeSize, sizeof(BYTE));
  202.  
  203.       // Inicializar el codificador
  204.       BitOffset:= 0;
  205.       InitTable(MinCodeSize);
  206.       WriteCode(hFile, ClearCode);
  207.       LineBuffer:= FBMPStream.ScanLine(0);
  208.  
  209.       if MinCodeSize >= 8 then
  210.         SuffixChar:= (LineBuffer[0] and $FF)
  211.       else
  212.         SuffixChar:= ((LineBuffer[0] and $F0) shr 4);
  213.  
  214.       inc(X);
  215.  
  216.       if X = Bitmap.Width then
  217.       begin
  218.         X:= 0;
  219.         inc(Y);
  220.       end;
  221.       if Y < Bitmap.Height then
  222.       begin
  223.         // Inicializar el prefijo
  224.         PrefixCode:= SuffixChar;
  225.  
  226.         XMax:= Bitmap.Width;
  227.         YMax:= Bitmap.Height;
  228.         LineBuffer:= FBMPStream.ScanLine(Y);
  229.         while (Y < YMax) and (pass < 4) do
  230.         begin
  231.             if MinCodeSize = 8 then
  232.             begin
  233.               SuffixChar:= LineBuffer[X];
  234.               inc(X)
  235.             end else
  236.             begin
  237.               if (X and 1) = 1 then SuffixChar:= (LineBuffer[X div 2] and $0F)  // Impar
  238.               else                  SuffixChar:= ((LineBuffer[X div 2]and $F0) shr 4); // Par
  239.               inc(X);
  240.             end;
  241.  
  242.             // Derive an index into the code table
  243.             hx:= (PrefixCode xor (SuffixChar shl 5)) mod TABLESIZE;
  244.             d := 1;
  245.  
  246.             while(TRUE) do
  247.             begin
  248.               // Mirar si el code esta en la tabla
  249.               if(CurrentCode[hx] = 0) then
  250.               begin
  251.                   // Si no, ponerlo
  252.                   inc(Result, WriteCode(hFile, PrefixCode));
  253.                   d:= FreeCode;
  254.  
  255.                   // Encontrar el siguiente FreeCode
  256.                   if(FreeCode <= LARGESTCODE) then
  257.                   begin
  258.                     OldCode[hx]:= PrefixCode;
  259.                     NewCode[hx]:= BYTE(SuffixChar);
  260.                     CurrentCode[hx]:= FreeCode;
  261.                     inc(FreeCode);
  262.                   end;
  263.  
  264.                   // Expand the code size or scrap the table
  265.                   if(d = MaxCode) then
  266.                   begin
  267.                     if(CodeSize < 12) then
  268.                     begin
  269.                         inc(CodeSize);
  270.                         MaxCode:= MaxCode shl 1;
  271.                     end else
  272.                     begin
  273.                         inc(Result, WriteCode(hFile, ClearCode));
  274.                         InitTable(MinCodeSize);
  275.                     end;
  276.                   end;
  277.                   PrefixCode:= SuffixChar;
  278.                   break;
  279.               end;
  280.               if(OldCode[hx] = PrefixCode) and (NewCode[hx] = SuffixChar) then
  281.               begin
  282.                   PrefixCode:= CurrentCode[hx];
  283.                   break;
  284.               end;
  285.               inc(hx, d);
  286.               inc(d, 2);
  287.               if(hx >= TABLESIZE) then dec(hx, TABLESIZE);
  288.             end;  // While TRUE
  289.  
  290.             // Incrementando X e Y
  291.             if(X >= XMax) then
  292.             begin
  293.               // Chequea imagen entrelazada
  294.               if Interlace = TRUE then
  295.               begin
  296.                   inc(Y, IncTable[pass]);
  297.                   if(Y >= YMax) then
  298.                   begin
  299.                     inc(pass);
  300.                     Y:= StarTable[pass];
  301.                   end;
  302.               end else inc(Y);
  303.               if Y = YMax then break;
  304.               X:= 0;
  305.               LineBuffer:= FBMPStream.ScanLine(Y);
  306.             end;
  307.         end;  // while (Y < YMax) and (pass < 4)
  308.       end;
  309.       // Escribe el PrefixCode
  310.       inc(Result, WriteCode(hFile, PrefixCode));
  311.  
  312.       // Escribe el EofCode
  313.       inc(Result, WriteCode(hFile, EofCode));
  314.  
  315.       // Flush the buffer
  316.       if(BitOffset > 0) then inc(Result, Flush(hFile, (BitOffset+7) div 8));
  317.  
  318.       // Escribe un bloque de longitud 0
  319.       inc(Result, Flush(hFile, 0));
  320.   end
  321.   else Result:= 0;
  322. end;
  323.  
  324. //------------------------------------------------------------------------------
  325. // Escribe un bucle NETSCAPE
  326. function TGIF.WriteLoopNetscape(hFile: integer): LongInt;
  327. begin
  328.   // Loop de Netscape
  329.   Result:= FileWrite(hFile, nl, sizeof(NETSCAPE_EXTENSION));
  330. end;
  331.  
  332. //------------------------------------------------------------------------------
  333. // Lee una extensión de comentario
  334. function TGIF.GetCommentExtension(Offset: LongInt): LongInt;
  335. var
  336.   n: integer;
  337.   AGifBuffer: PByteArray;
  338. begin
  339.   AGifBuffer:= PByteArray(GifBuffer);
  340.   if(AGifBuffer[Offset] = BYTE('!')) and (AGifBuffer[Offset+1] = $FE) then
  341.   begin
  342.       n:= 1;
  343.       inc(Offset, 2);
  344.       while (n <> -1{EOF}) and (n > 0) do
  345.       begin
  346.         n:= AGifBuffer[Offset];
  347.         inc(Offset, 1);
  348.         Comments.Text:= Comments.Text + Copy(PCHAR(GifBuffer + Offset), 0, n);
  349.         inc(Offset, n);
  350.       end;
  351.   end;
  352.   Result:= Offset;
  353. end;
  354.  
  355. //------------------------------------------------------------------------------
  356. // Escribe una extensión de comentario
  357. function TGIF.WriteComment(hFile: integer; Comment: PCHAR): LongInt;
  358. var
  359.   CEH: COMMENT_EXTENSION_HEADER;
  360.   Len: integer;
  361.   L, nbytes, Nulo: BYTE;
  362. begin
  363.   Nulo:= 0;
  364.   Result:= 0;
  365.   CEH.Introducer:= BYTE('!');
  366.   CEH.Label_E:= $FE;
  367.   Len:= Length(Comment);
  368.   L:= 0;
  369.   Result:= FileWrite(hFile, CEH, sizeof(CEH.Introducer) + sizeof(CEH.Label_E));
  370.   while(L < Len) do
  371.   begin
  372.     nbytes:= min(Len, 255);
  373.     inc(Result, FileWrite(hFile, nbytes, 1));
  374.     nbytes:= min(Len-L, 255);
  375.     inc(L, FileWrite(hFile, Comment^, nbytes));
  376.     inc(Comment, L);
  377.   end;
  378.   inc(Result, L + FileWrite(hFile, Nulo, 1)); // Bloque nulo: Fin de Extensión
  379. end;
  380.  
  381. //------------------------------------------------------------------------------
  382. function TGIF.CmpPalette(Palette: pointer; nColors: integer): boolean;
  383. begin
  384.   Result:= FALSE;
  385.   if(DefPalette <> nil) and (Palette <> nil) and (ncolors = DefNColors) then
  386.       Result:= CompareMem(Palette, DefPalette, DefNColors*3);
  387. end;
  388.  
  389. //------------------------------------------------------------------------------
  390. procedure TGIF.InitTable(MinCodeSize: integer);
  391. begin
  392.   CodeSize := WORD(MinCodeSize+1);
  393.   ClearCode:= WORD(1 shl MinCodeSize);
  394.   EofCode  := WORD(ClearCode+1);
  395.   FreeCode := WORD(ClearCode+2);
  396.   MaxCode  := WORD(1 shl CodeSize);
  397.  
  398.   //ZeroMemory(CurrentCode, TABLESIZE * sizeof(WORD));
  399.   FillChar(CurrentCode[0], TABLESIZE * sizeof(WORD), 0);
  400. end;
  401.  
  402. //------------------------------------------------------------------------------
  403. procedure  TGIF.BuildWBuffers();
  404. begin
  405.   SetLength(DefPalette, 256);
  406.   SetLength(CodeBuffer, 259);
  407.   SetLength(OldCode, TABLESIZE);
  408.   SetLength(CurrentCode, TABLESIZE);
  409.   SetLength(NewCode, TABLESIZE);
  410.  
  411.   //ZeroMemory(CurrentCode, TABLESIZE * sizeof(WORD));
  412.   FillChar(CurrentCode[0], TABLESIZE * sizeof(WORD), 0);
  413. end;
  414.  
  415.  
  416. end.   


Cuando sea posible, subo todo el código en un adjunto.

Saludos.
  • 0

#17 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 19 junio 2011 - 10:40

Lo siguiente es un visor de animaciones GIF para Lazarus:


delphi
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4. interface
  5.  
  6. uses
  7.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  8.   StdCtrls, gif;
  9.  
  10. type
  11.  
  12.   { TForm1 }
  13.  
  14.   TForm1 = class(TForm)
  15.     Open: TButton;
  16.     Save: TButton;
  17.     Image1: TImage;
  18.     Label1: TLabel;
  19.     Label2: TLabel;
  20.     OpenDialog1: TOpenDialog;
  21.     SaveDialog1: TSaveDialog;
  22.     Timer1: TTimer;
  23.     procedure OpenClick(Sender: TObject);
  24.     procedure SaveClick(Sender: TObject);
  25.     procedure FormCreate(Sender: TObject);
  26.     procedure Timer1Timer(Sender: TObject);
  27.   private
  28.     { private declarations }
  29.   public
  30.     n: integer;
  31.     Gif: TGIF;
  32.     { public declarations }
  33.   end;
  34.  
  35. var
  36.   Form1: TForm1;
  37.  
  38. implementation
  39.  
  40. {$R *.lfm}
  41.  
  42. { TForm1 }
  43. procedure TForm1.FormCreate(Sender: TObject);
  44. begin
  45.   DoubleBuffered:= TRUE;
  46.   Gif:= TGIF.Create;
  47.   Timer1.Enabled:= false;
  48.   Timer1.Interval:= 50;
  49. end;
  50.  
  51. procedure TForm1.OpenClick(Sender: TObject);
  52. begin
  53.   if(OpenDialog1.Execute()) then
  54.   begin
  55.       gif.LoadFromFile(OpenDialog1.FileName);
  56.       Timer1.Enabled:= gif.Loop;
  57.       Image1.Picture.Bitmap.Assign(gif.GetBitmap);
  58.   end;
  59. end;
  60.  
  61. procedure TForm1.SaveClick(Sender: TObject);
  62. begin
  63.   if(Image1.Picture.Bitmap.Empty = FALSE) then
  64.   begin
  65.       if SaveDialog1.Execute then
  66.       begin
  67.         gif.SaveToFile(SaveDialog1.FileName);
  68.         Image1.Picture.Bitmap.Assign(gif.GetBitmap);
  69.       end;
  70.   end;
  71. end;
  72.  
  73. procedure TForm1.Timer1Timer(Sender: TObject);
  74. var
  75.     i: integer;
  76. begin
  77.     i:= n mod Gif.GetBitmapCount;
  78.     Timer1.Interval:= Gif.GetGraphicBlock(i)^.DelayTime*10;
  79.     if Timer1.Interval = 0 then Timer1.Interval:= 40;
  80.     Image1.Canvas.Draw(Gif.GetGraphicBlock(i)^.Left, Gif.GetGraphicBlock(i)^.Top, Gif.GetBitmap(i));
  81.     inc(n);
  82. end;
  83.  
  84. end.



Saludos.
  • 0

#18 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 19 junio 2011 - 11:49

Parece que el problema de los archivos adjuntos está resuelto gracias a egostar.  (y)

Lo prometido es deuda, así que subo un archivo adjunto con todo el código. :)


Saludos.

Archivos adjuntos


  • 1

#19 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.858 mensajes
  • LocationMadrid - España

Escrito 23 septiembre 2018 - 05:55

Pasados unos cuantos años he vuelto sobre este tema tras darme cuenta de la falta de compatibilidad de las clase con algunos GIF y sobre todo debido al soporte muy parcial que hace Windows con GDIplus. En efecto, GDI plus no es compatible con todos los "Disponsal Method" (formas de eliminación de cada frame animado) definidos en la especificación Gif89a y tampoco permite escribir archivos gif de más de una imagen. Llevado por esta situación y viendo que la clase TGIF que escribí es mucho más versátil y potente, la he actualizado. En realidad los cambios son mínimos.

 

Uno de los temas más complejos es el tratamiento preciso del Disponsal Method tipo 3 que no todas las implementaciones lo hacen bien. En principio yo dejé este tema para la implementación del visor, pero he pensado que sería mejor idea dar soporte desde una función ya implementada que, aunque no me parecía que debiese pertenecer a la clase TGIF, ya que ésta está enfocada para los archivos y no para el visor (quizás la debería haber llamado TGifFile), si me pareció interesante aportarla para facilitar toda la funcionalidad a la construcción de un visor o de una creador de gif animados.

 

Otro problema son las transparencias. Por lo general, en un mundo en el que el problema de espacio de memoria no es el que había hace décadas, los formatos de color indexado se contemplan poco y las transparencias vienen dadas por color y no por índice de color. Esto supone que algunos gif pueden tener varios colores iguales en la paleta pero sólo uno de ellos será transparente con lo que tenemos una ambigüedad. Si tanto la API como las implementaciones de ayudas gráficas de los lenguajes se basan en un color y no en un índice, el problema no está resuelto. En la clase TGIF lo resuelvo escaneando los colores de la paleta y cambiando ligeramente los repetidos.

 

Comentar que la versión Lazarus difiere de la de delphi porque no soporta TBitmaps de color indexado, esto me obligó a escribir una clase de apoyo para conseguirlo, basada en Stream, que permite el uso de paletas y colores indexados.

 

Para el que no sepa las interioridades del formato gif, he de aclarar que nació en una época en la que el ahorro de memoria era básico en las máquinas y en el streaming por la red. Esto supuso el uso de bitmaps de color indexado y paletas, mucho más pequeños que los bitmaps de color verdadero de 24 ó 32 bits, en la que cada color se guarda con cada pixel. También supuso la creación de un algoritmo de compresión. Estas animaciones se usaron en los navegadores web. Netscape tuvo mucho que ver con propuestas al formato, como el famoso looping que dio lugar a las animaciones sin fin que hoy conocemos como algo habitual

 

Aunque no es lo común en el código que suelo publicar, al implementar esta clase he huido del uso del API de Windows, para facilitar una posible futura portabilidad y para no alejarme de la implementación para Lazarus.

 

Las mejoras se pueden resumir así:

1. Mejor implementación de los Disponsal Methods en una función de soporte PaintGB.

2. Mejoras en las transparencias debido al problema de dar un índice de color y no el color mismo.

3. Se añade una función que no pertenece a la clase, para dar soporte a la visualización.

 

La función de apoyo para visualización es la siguiente:

(versiones de delphi lazarus y cpp),


delphi
  1. // Delphi 7 y Berlin
  2. //---------------------------------------------------------------------------
  3. // Dibuja un GraphicBlock de un Gif localizado por su índice respetando el
  4. // DisponsalMethod del fotograma que se va a quitar
  5. procedure PaintGB(Canvas: TCanvas; var Gif: TGIF; Index: integer; BkColor: TColor; _Forward: boolean);
  6. var
  7. Frames: integer;
  8. OldDisponsalMethod: BYTE;
  9. OldIndex: integer;
  10. begin
  11. Frames:= Gif.GetBitmapCount();
  12.  
  13. if _Forward then
  14. OldIndex:= (Frames + Index -1) mod Frames
  15. else
  16. OldIndex:= (Index + 1) mod Frames;
  17.  
  18. OldDisponsalMethod:= Gif.GetGraphicBlock(OldIndex).Method;
  19.  
  20. // Method = 0 (Sin accion específica) y Method = 1 (No se quita la imagen)
  21. if OldDisponsalMethod < 2 then
  22. begin
  23. // No se borra la imagen se deja como está...
  24. end;
  25.  
  26. // Method = 2 (Se restaura al color de fondo)
  27. if OldDisponsalMethod = 2 then
  28. begin
  29. Canvas.Brush.Color:= BkColor;
  30. Canvas.FillRect(Canvas.ClipRect);
  31. end;
  32.  
  33. // Method = 3 (Se restaura al estado previo el area sobreescrita)
  34. if OldDisponsalMethod = 3 then
  35. begin
  36. Canvas.Draw(Gif.GetGraphicBlock(OldIndex).Left, Gif.GetGraphicBlock(OldIndex).Top, Gif.OldImage);
  37. end;
  38.  
  39. // Guardando la imagen previa para el caso de DisponsalMethod = 3
  40. if Gif.GetGraphicBlock(Index).Method = 3 then
  41. begin
  42. Gif.OldImage.Width:= Gif.GetBitmap(Index).Width;
  43. Gif.OldImage.Height:= Gif.GetBitmap(Index).Height;
  44. Gif.OldImage.Canvas.CopyMode:= cmSrcCopy;
  45. Gif.OldImage.Canvas.CopyRect(Gif.GetFrameRect(Index), Canvas, Gif.GetBitmapRect(Index));
  46. end;
  47.  
  48. // Dibujando la imegen actual
  49. Canvas.Draw(Gif.GetGraphicBlock(Index).Left, Gif.GetGraphicBlock(Index).Top, Gif.GetBitmap(Index));
  50. end;


delphi
  1. // Lazarus
  2. //---------------------------------------------------------------------------
  3. // Dibuja un GraphicBlock de un Gif localizado por su índice respetando el
  4. // DisponsalMethod del fotograma que se va a quitar
  5. procedure PaintGB(Canvas: TCanvas; var Gif: TGIF; Index: integer; BkColor: TColor; _Forward: boolean);
  6. var
  7. Frames: integer;
  8. OldDisponsalMethod: BYTE;
  9. OldIndex: integer;
  10. begin
  11. Frames:= Gif.GetBitmapCount();
  12.  
  13. if _Forward then
  14. OldIndex:= (Frames + Index -1) mod Frames
  15. else
  16. OldIndex:= (Index + 1) mod Frames;
  17.  
  18. OldDisponsalMethod:= Gif.GetGraphicBlock(OldIndex).Method;
  19.  
  20. // Method = 0 (Sin accion específica) y Method = 1 (No se quita la imagen)
  21. if OldDisponsalMethod < 2 then
  22. begin
  23. // No se borra la imagen se deja como está...
  24. end;
  25.  
  26. // Method = 2 (Se restaura al color de fondo)
  27. if OldDisponsalMethod = 2 then
  28. begin
  29. Canvas.Brush.Color:= BkColor;
  30. Canvas.FillRect(Canvas.ClipRect);
  31. end;
  32.  
  33. // Method = 3 (Se restaura al estado previo el area sobreescrita)
  34. if (OldDisponsalMethod = 3) then
  35. begin
  36. Canvas.Draw(Gif.GetGraphicBlock(OldIndex).Left, Gif.GetGraphicBlock(OldIndex).Top, Gif.OldImage);
  37. end;
  38.  
  39. // Guardando la imagen previa para el caso de DisponsalMethod = 3
  40. if Gif.GetGraphicBlock(Index).Method = 3 then
  41. begin
  42. Gif.OldImage.Width:= Gif.GetBitmap(Index).Width;
  43. Gif.OldImage.Height:= Gif.GetBitmap(Index).Height;
  44. Gif.OldImage.Canvas.CopyMode:= cmSrcCopy;
  45. Gif.OldImage.Canvas.CopyRect(Gif.GetFrameRect(Index), Canvas, Gif.GetBitmapRect(Index));
  46. end;
  47.  
  48. // Dibujando la imegen actual
  49. Canvas.Draw(Gif.GetGraphicBlock(Index).Left, Gif.GetGraphicBlock(Index).Top, Gif.GetBitmap(Index));
  50. end;


cpp
  1. // Cpp Builder 5 y Berlin
  2. //---------------------------------------------------------------------------
  3. // Dibuja un GraphicBlock de un Gif localizado por su índice respetando el
  4. // DisponsalMethod del fotograma que se va a quitar
  5. void PaintGB(TCanvas *Canvas, TGIF* Gif, int Index, TColor BkColor, bool Forward)
  6. {
  7. int Frames = Gif->GetBitmapCount();
  8. int OldIndex;
  9. if(Forward)
  10. OldIndex = (Frames + Index -1) % Frames;
  11. else
  12. OldIndex = (Index + 1) % Frames;
  13.  
  14. BYTE OldDisponsalMethod = Gif->GetGraphicBlock(OldIndex)->Method;
  15.  
  16. // Method = 0 (Sin accion específica) y Method = 1 (No se quita la imagen)
  17. if(OldDisponsalMethod < 2){
  18. // No se borra la imagen se deja como está...
  19. }
  20.  
  21. // Method = 2 (Se restaura al color de fondo)
  22. if(OldDisponsalMethod == 2){
  23. Canvas->Brush->Color = BkColor;
  24. Canvas->FillRect(TRect(0,0,Gif->ScreenWidth, Gif->ScreenHeight));//.Canvas->ClipRect);
  25. }
  26.  
  27. // Method = 3 (Se restaura al estado previo el area sobreescrita)
  28. if(OldDisponsalMethod == 3){// && Index > 0){
  29. Canvas->Draw(Gif->GetGraphicBlock(OldIndex)->Left, Gif->GetGraphicBlock(OldIndex)->Top, Gif->OldImage);
  30. }
  31.  
  32. // Guardando la imagen previa para el caso de DisponsalMethod = 3
  33. if(Gif->GetGraphicBlock(Index)->Method == 3){
  34. Gif->OldImage->Width = Gif->GetBitmap(Index)->Width;
  35. Gif->OldImage->Height = Gif->GetBitmap(Index)->Height;
  36. Gif->OldImage->Canvas->CopyMode = cmSrcCopy;
  37. TRect DestRect = Gif->GetFrameRect(Index);
  38. TRect SourceRect = Gif->GetBitmapRect(Index);
  39. Gif->OldImage->Canvas->CopyRect(DestRect, Canvas, SourceRect);
  40. }
  41.  
  42. // Dibujando la imegen actual
  43. Canvas->Draw(Gif->GetGraphicBlock(Index)->Left, Gif->GetGraphicBlock(Index)->Top, Gif->GetBitmap(Index));
  44. }

Hay que tener muy presente un detalle a la hora de visualizar un Gif que use Disponsal Method tipo 3, como al desaparecer un frame debe restaurarlo con lo que había en su lugar antes de ser representado, si por un error en la implementación, representáramos dos veces ese frame (dos llamadas consecutivas a la función) ya no tendríamos  la imagen previa guardada correctamente, es por eso que la función permite pintar hacia delante y hacia atrás, pero jamás se debe pintar dos veces el mismo frame del tipo 3 si queremos que la visualización sea fiel a lo que diseñó la persona que creó el gif.

 

Sobre la base de esta revisión voy a publicar le revisión del componente TGifViewer, para delphi, compatible con Berlin. Otra versión para Builder, también compatible con Berlin. Y añadiré otra versión para Lazarus. También publicaré una pequeña aplicación para visualizar gif, editarlos o crear alguna pequeña animación, GIF Creator.

 

 

 

Saludos.

Archivos adjuntos


  • 1

#20 enecumene

enecumene

    Webmaster

  • Administrador
  • 7.408 mensajes
  • LocationRepública Dominicana

Escrito 23 septiembre 2018 - 12:04

Bestial


  • 0