mirror of
https://github.com/doublecmd/doublecmd.git
synced 2026-06-28 10:02:14 +00:00
2785 lines
95 KiB
ObjectPascal
2785 lines
95 KiB
ObjectPascal
Unit uGifViewer;
|
|
|
|
(*==============================================================================
|
|
DESCRIPTION : Visual component for displaying an animated image in the
|
|
GIF (Graphic Interchange Format) format
|
|
DATE : 17/06/2018
|
|
UPDATE : 01/07/2025
|
|
VERSION : 1.0
|
|
AUTHOR : J.Delauney (BeanzMaster)
|
|
CONTRIBUTORS : Jipete, Jurassik Pork, bpranoto, Alexander Koblov
|
|
LICENSE : MPL 2.0
|
|
================================================================================
|
|
*)
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
Interface
|
|
|
|
Uses
|
|
Types, Classes, SysUtils, Graphics, Math, Contnrs, Dialogs,
|
|
Controls, ExtCtrls,
|
|
Lresources, GifViewerStrConsts,
|
|
uFastBitmap;
|
|
|
|
{%region=====[ Définitions des types et constantes utiles pour le format GIF ]===================================}
|
|
Const
|
|
GIF_MaxColors : Integer = 256; // Nombre de couleurs maximum supportées. NE PAS TOUCHER A CETTE VALEUR
|
|
GIF_DelayFactor : Integer = 10; // Facteur de multiplication pour les délais en ms entre chaque image de l'animation
|
|
GIF_DefaultDelay : Integer = 100; // 10*10
|
|
|
|
Type
|
|
TGIFVersion = (gvUnknown, gv87a, gv89a);
|
|
TGIFVersionRec = Array[0..2] Of AnsiChar;
|
|
|
|
Const
|
|
GIFVersions : Array[gv87a..gv89a] Of TGIFVersionRec = ('87a', '89a');
|
|
|
|
Type
|
|
{ En-tête }
|
|
TGIFFileHeader = Packed Record
|
|
Signature: Array[0..2] Of AnsiChar; // 'GIF'
|
|
Version: TGIFVersionRec; // '87a' ou '89a' }
|
|
End;
|
|
|
|
{ Description globale de l'image }
|
|
TGIFLogicalScreenDescriptorRec = Packed Record
|
|
ScreenWidth: Word; // Largeur de l'image en pixels // Width
|
|
ScreenHeight: Word; // Hauteur de l'image en pixels // Height
|
|
PackedFields: Byte; // champs compactés // Compacted field
|
|
BackgroundColorIndex: Byte; // Index globale de la couleur de fond // Index of background color
|
|
AspectRatio: Byte; // Ratio d'échelle = (AspectRatio + 15) / 64
|
|
End;
|
|
|
|
{ Description d'une image }
|
|
TGIFImageDescriptorRec = Packed Record
|
|
//Separator: byte; // On lis toujours un byte avant // we always read it before
|
|
Left: Word; // Colonne en pixels par rapport au bord gauche de l'écran // Column in pixels from the left edge of the screen
|
|
Top: Word; // Rangée en pixels par rapport au haut de l'écran // Row in pixels from the top edge of the screen
|
|
Width: Word; // Largeur de l'image en cours en pixels // image width
|
|
Height: Word; // Hauteur de l'image en cours pixels // Image height
|
|
PackedFields: Byte; // Champs compactés // Compacted field
|
|
End;
|
|
|
|
{ Graphic Control Extension bloc a.k.a GCE }
|
|
TGIFGraphicControlExtensionRec = Packed Record
|
|
// BlockSize: byte; // Normalement toujours 4 octets // Always 4 bytes
|
|
PackedFields: Byte; // Champs compacté // Compacted field
|
|
DelayTime: Word; // Délai entre chaque image en centième de secondes // Delay between each image in hundredths of a second
|
|
TransparentColorIndex: Byte; // Index dans la palette si plus petit ou égale // Delay between each image in hundredths of a second
|
|
// Terminator: Byte; // Normalement toujours ZERO // Normally always ZERO
|
|
End;
|
|
|
|
TGIFDisposalFlag = (dmNone, dmKeep, dmErase, dmRestore); // Methodes pour l'affichage des images lors de l'animation
|
|
|
|
{ Plain Text Extension }
|
|
TGIFPlainTextExtensionRec = Packed Record
|
|
// BlockSize: byte; // Normalement égal à 12 octets // Normally equal to 12 bytes
|
|
Left, Top, Width, Height: Word; // Positions et dimensions du texte // position and dimension of text
|
|
CellWidth, CellHeight: Byte; // Dimensions d'une cellule dans l'image // Size of cell
|
|
TextFGColorIndex, // Index de la couleur de fond dans la palette // Index of the background color
|
|
TextBGColorIndex: Byte; // Index de la couleur du texte dans la palette // Index of the text color
|
|
End;
|
|
|
|
{ Application Extension }
|
|
TGIFApplicationExtensionRec = Packed Record
|
|
AppID: Array [0..7] Of AnsiChar; // Identification de l'application majoritairement 'NETSCAPE' ou ''
|
|
AppAuthenticationCode: Array [0..2] Of AnsiChar; // Code d'authentification ou numero de version
|
|
End;
|
|
|
|
{ Informations de "l'application extension" si disponible }
|
|
TGIFNSLoopExtensionRec = Packed Record
|
|
Loops: Word; // Nombre de boucle de l'animation 0 = infinie // nb loop
|
|
BufferSize: DWord; // Taille du tampon. Usage ?????
|
|
End;
|
|
|
|
Const
|
|
// Description des masques pour la description globale de l'image
|
|
GIF_GLOBALCOLORTABLE = $80; // Défini si la table de couleurs globale suit la description globale
|
|
GIF_COLORRESOLUTION = $70; // Résolution de la couleur (BitsPerPixel) - 3 bits
|
|
GIF_GLOBALCOLORTABLESORTED = $08; // Définit si la palette globale est triée - 1 bit
|
|
GIF_COLORTABLESIZE = $07; // Taille de la palette - 3 bits
|
|
GIF_RESERVED = $0C; // Réservé - doit être défini avec $00 - Taille des données = 2^value+1 - 3 bits
|
|
|
|
// Descption des masques pour les images
|
|
GIF_LOCALCOLORTABLE = $80; // Défini si la table de couleurs locale suit la description de l'image
|
|
GIF_INTERLACED = $40; // Défini si l'image est entrelacée
|
|
GIF_LOCALCOLORTABLESORTED = $20; // Définit si la palette locale est triée
|
|
|
|
// Identification des blocs
|
|
GIF_PLAINTEXT = $01;
|
|
GIF_GRAPHICCONTROLEXTENSION = $F9;
|
|
GIF_COMMENTEXTENSION = $FE;
|
|
GIF_APPLICATIONEXTENSION = $FF;
|
|
GIF_IMAGEDESCRIPTOR = $2C; // ','
|
|
GIF_EXTENSIONINTRODUCER = $21; // '!'
|
|
GIF_TRAILER = $3B; // ';'
|
|
|
|
// Graphic Control Extension - Définition des masques pour les paramètres
|
|
GIF_NO_DISPOSAL = $00; // 0
|
|
GIF_DO_NOT_DISPOSE = $04; // 1
|
|
GIF_RESTORE_BACKGROUND_COLOR = $08; // 2
|
|
GIF_RESTORE_PREVIOUS = $12; // 3
|
|
GIF_DISPOSAL_ALL = $1C; // bits 2-4 ($1C)
|
|
GIF_USER_INPUT_FLAG = $02;
|
|
GIF_TRANSPARENT_FLAG = $01;
|
|
GIF_RESERVED_FLAG = $E0;
|
|
|
|
// Identification des sous-blocs pour "Application Extension"
|
|
GIF_LOOPEXTENSION = 1;
|
|
GIF_BUFFEREXTENSION = 2;
|
|
|
|
Const
|
|
GifGCEDisposalModeStr : Array[TGIFDisposalFlag] Of String = ('None', 'Keep', 'Erase', 'Restore');
|
|
|
|
Type
|
|
{ Informations sur une image de l'animation }
|
|
TGIFFrameInformations = Record
|
|
Left, Top, // Position de l'image
|
|
Width, Height: Integer; // Dimension de l'image
|
|
HasLocalPalette: Boolean; // Palette locale disponible
|
|
IsTransparent: Boolean; // Image transparente
|
|
UserInput: Boolean; // Données personnelle
|
|
BackgroundColorIndex: Byte; // Normalement seulement valide si une palette globale existe
|
|
TransparentColorIndex: Byte; // Index de la couleur transparente
|
|
DelayTime: Word; // Délai d'animation
|
|
Disposal: TGIFDisposalFlag; // Methode d'affichage
|
|
Interlaced: Boolean; // Image entrelacée
|
|
End;
|
|
PGifFrameInformations = ^TGifFrameInformations;
|
|
|
|
{%endregion%}
|
|
|
|
{ TGIFFastMemoryStream }
|
|
{ Classe d'aide à la lecture des données dans un flux en mémoire }
|
|
TGIFFastMemoryStream = Class
|
|
Private
|
|
FBuffer: PByte;
|
|
FPosition: Int64;
|
|
FBytesRead, FBytesLeft, FSize: Int64;
|
|
Public
|
|
Constructor Create(AStream : TStream);
|
|
Destructor Destroy; Override;
|
|
|
|
{ Lit un Byte dans le tampon / Read a byte in buffer }
|
|
Function ReadByte: Byte;
|
|
{ Lit un Word dans le tampon / Read a word in buffer}
|
|
Function ReadWord: Word;
|
|
{ Lit un DWord dans le tampon / Read a DWord in buffer }
|
|
Function ReadDWord: DWord;
|
|
{ Lit et retourne un tampon "Buffer" de taille "Count" octets / Read a buffer of size "count" }
|
|
Function Read(Var Buffer; Count : Int64): Int64;
|
|
{ Déplacement dans le flux de "Offset" depuis "Origin"
|
|
TSeekOrigin =
|
|
- soBeginning : Depuis le début du flux
|
|
- soCurrent : a partir de la position courante
|
|
- soEnd : A partir de la fin du flux
|
|
}
|
|
Function Seek(Const Offset : Int64; Origin : TSeekOrigin): Int64;
|
|
{ Déplacement dans le flux vers l'avant de "Cnt" octet depuis la position courrante }
|
|
Procedure SeekForward(Cnt : Integer);
|
|
{ Indique si la fin du flux est atteinte (EOS = End Of Stream) }
|
|
Function EOS: Boolean;
|
|
|
|
{ Retourne la taille du flux en octet // Size in byte of the buffer}
|
|
Property Size: Int64 read FSize;
|
|
{ Retourne la position courrante de lecture dans le tampon // Current position in buffer }
|
|
Property Position: Int64 read FPosition;
|
|
End;
|
|
|
|
{ TGIFLoadErrorEvent : Fonction d'évènement levée en cas d'erreur(s) dans le chargement // Event raise on error }
|
|
TGIFLoadErrorEvent = Procedure(Sender : TObject; Const ErrorCount : Integer; Const ErrorList : TStringList) Of Object;
|
|
|
|
{ TGIFImageListItem }
|
|
{ Définition d'une image contenue dans le fichier GIF }
|
|
TGIFImageListItem = Class
|
|
Private
|
|
FBitmap: TFastBitmap;
|
|
FDrawMode: TGIFDisposalFlag;
|
|
FLeft, FTop: Integer;
|
|
FComment: TStringList;
|
|
FDelay: Integer;
|
|
FTransparent: Boolean;
|
|
FIsCorrupted : Boolean;
|
|
Protected
|
|
Public
|
|
Constructor Create;
|
|
Destructor Destroy; Override;
|
|
|
|
{ Objet contenant l'image }
|
|
Property Bitmap: TFastBitmap read FBitmap write FBitmap;
|
|
{ Mode de rendu de l'image // Render Mode}
|
|
Property DrawMode: TGIFDisposalFlag read FDrawMode write FDrawMode;
|
|
{ Position gauche de l'image }
|
|
Property Left: Integer read FLeft write FLeft;
|
|
{ Position Haut de l'image }
|
|
Property Top: Integer read FTop write FTop;
|
|
{ Temps d'attente entre deux image de l'animation }
|
|
Property Delay: Integer read FDelay write FDelay;
|
|
{ Commentaire sur l'image }
|
|
Property Comment: TStringList read FComment write FComment;
|
|
{ Retourne TRUE si l'image utilise la transparence }
|
|
Property IsTransparent: Boolean read FTransparent write FTransparent;
|
|
{ Indique si l'image est corrompue }
|
|
property IsCorrupted : Boolean read FIsCorrupted write FIsCorrupted;
|
|
End;
|
|
|
|
{ TGIFImageList }
|
|
{ Classe d'aide à la gestion des images contenues dans le fichier GIF }
|
|
{ Helper class for manage image in GIF }
|
|
TGIFImageList = Class(TObjectList)
|
|
Private
|
|
Protected
|
|
Function GetItems(Index : Integer): TGIFImageListItem;
|
|
Procedure SetItems(Index : Integer; AGifImage : TGIFImageListItem);
|
|
Public
|
|
{ Efface la liste }
|
|
Procedure Clear; Override;
|
|
{ Ajoute une nouvelle image vide à la liste }
|
|
Function AddNewImage: TGIFImageListItem;
|
|
{ Ajout d'une image dans la liste }
|
|
Function Add(AGifImage : TGIFImageListItem): Integer;
|
|
{ Extraction d'une image de la liste }
|
|
Function Extract(Item : TGIFImageListItem): TGIFImageListItem;
|
|
{ Effacement d'une image dans la liste }
|
|
Function Remove(AGifImage : TGIFImageListItem): Integer;
|
|
{ Retourne l'index de l'image recherchée (retourne -1 si non trouvé) }
|
|
Function IndexOf(AGifImage : TGIFImageListItem): Integer;
|
|
{ Retourne la première image }
|
|
Function First: TGIFImageListItem;
|
|
{ Retourne la dernière image }
|
|
Function Last: TGIFImageListItem;
|
|
{ Insertion d'une image à la position "Index" }
|
|
Procedure Insert(Index : Integer; AGifImage : TGIFImageListItem);
|
|
|
|
{ Liste des images }
|
|
Property Items[Index: Integer]: TGIFImageListItem read GetItems write SetItems; Default;
|
|
End;
|
|
|
|
{ TGIFImageLoader }
|
|
{ Classe spécialisée pour la lecture d'une image au format GIF }
|
|
{ Special class for read a GIF }
|
|
TGIFImageLoader = Class
|
|
Private
|
|
FCurrentLayerIndex: Integer;
|
|
FGIFFIleHeader: TGIFFileHeader;
|
|
FLogicalScreenChunk: TGIFLogicalScreenDescriptorRec;
|
|
FHasGlobalPalette: Boolean;
|
|
FTransparent: Boolean;
|
|
FGlobalPalette: TColor32List;
|
|
FVersion: String;
|
|
|
|
FWidth, FHeight: Integer;
|
|
FBackgroundColor: TColor32;
|
|
|
|
FFrames: TGIFImageList;
|
|
|
|
FErrorList: TStringList;
|
|
FErrorCount: Integer;
|
|
FOnLoadError: TGIFLoadErrorEvent;
|
|
Procedure SetCurrentLayerIndex(AValue : Integer);
|
|
|
|
Protected
|
|
Memory: TGIFFastMemoryStream;
|
|
|
|
CurrentFrameInfos: TGifFrameInformations;
|
|
|
|
Function GetFrameCount: Integer;
|
|
Procedure LoadFromMemory();
|
|
Function CheckFormat(): Boolean;
|
|
Function ReadImageProperties: Boolean;
|
|
Procedure AddError(Msg : String);
|
|
Procedure NotifyError;
|
|
Public
|
|
Constructor Create;
|
|
Destructor Destroy; Override;
|
|
|
|
{ LoadFromStream : Charge les données depuis un flux }
|
|
Procedure LoadFromStream(aStream : TStream); Virtual;
|
|
{ LoadFromFile : Charge les données depuis un fichier physique }
|
|
Procedure LoadFromFile(Const FileName : String); Virtual;
|
|
{ Chargement depuis une Resource Lazarus }
|
|
Procedure LoadFromResource(Const ResName : String);
|
|
{ Retourne la version du fichier GIF }
|
|
Property Version: String read FVersion;
|
|
{ Retourne la largeur de l'image GIF }
|
|
Property Width: Integer read FWidth;
|
|
{ Retourne la hauteur de l'image GIF }
|
|
Property Height: Integer read FHeight;
|
|
{ Retourne la couleur de l'image GIF si elle existe,. Sinon retourne une couleur transparente (clrTransparent) }
|
|
Property BackgroundColor: TColor32 read FBackgroundColor write FBackgroundColor;
|
|
{ Prise en charge de la transparence dans l'image GIF // Take transparency in account}
|
|
Property Transparent: Boolean read FTransparent write FTransparent;
|
|
{ Retourne l'index courrant de l'image de l'animation traité // Return the current index frame}
|
|
Property CurrentFrameIndex: Integer read FCurrentLayerIndex write SetCurrentLayerIndex;
|
|
{ Liste des images de l'animation // List of frame}
|
|
Property Frames: TGIFImageList read FFrames;
|
|
{ Nombre d'image de l'animation // Nb frames }
|
|
Property FrameCount: Integer read GetFrameCount;
|
|
{ Nombre d'erreur produite loars d'un cahrgement ou d'un enregistrement // Nb error }
|
|
Property ErrorCount: Integer read FErrorCount;
|
|
{ Liste des erreurs // List of error }
|
|
Property Errors: TStringList read FErrorList;
|
|
|
|
{ Evenement pour intercepter les erreurs notifiées lors du chargement des données // Error Event }
|
|
Property OnLoadError: TGIFLoadErrorEvent read FOnLoadError write FOnLoadError;
|
|
End;
|
|
|
|
{ TGIFRenderCacheListItem }
|
|
{ Définition d'une image cache de l'animation }
|
|
{ Image cache class }
|
|
TGIFRenderCacheListItem = Class
|
|
Private
|
|
FBitmap: Graphics.TBitmap;
|
|
FDelay: Integer;
|
|
FIsCorrupted : Boolean;
|
|
Public
|
|
Constructor Create;
|
|
Destructor Destroy; Override;
|
|
{ Image cache prérendu de l'animation }
|
|
Property Bitmap: Graphics.TBitmap read FBitmap write FBitmap;
|
|
{ Temps d'attente en ms avec l'image suivante }
|
|
Property Delay: Integer read FDelay write FDelay;
|
|
{ Indique si l'image est corrompue }
|
|
property IsCorrupted : Boolean read FIsCorrupted write FIsCorrupted;
|
|
End;
|
|
|
|
{ TGIFRenderCacheList }
|
|
{ Classe d'aide à la gestion des images rendues de l'animation }
|
|
{ Helper class for manage list of image cache }
|
|
TGIFRenderCacheList = Class(TObjectList)
|
|
Private
|
|
Protected
|
|
Function GetItems(Index : Integer): TGIFRenderCacheListItem;
|
|
Procedure SetItems(Index : Integer; AGIFRenderCache : TGIFRenderCacheListItem);
|
|
Public
|
|
{ Efface la liste }
|
|
Procedure Clear; Override;
|
|
{ Ajoute un nouvel objet cache vide }
|
|
Function AddNewCache: TGIFRenderCacheListItem;
|
|
{ Ajoute un nouveau cache }
|
|
Function Add(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
{ Extrait un cache de la liste }
|
|
Function Extract(Item : TGIFRenderCacheListItem): TGIFRenderCacheListItem;
|
|
{ Supprime un cache de la liste }
|
|
Function Remove(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
{ Retourne l'index du cache recherchée (retourne -1 si non trouvé) }
|
|
Function IndexOf(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
{ Retourne le premier élément de la liste }
|
|
Function First: TGIFRenderCacheListItem;
|
|
{ Retourne le dernier élément de la liste }
|
|
Function Last: TGIFRenderCacheListItem;
|
|
{ Insertion d'un cache à la position "Index" }
|
|
Procedure Insert(Index : Integer; AGIFRenderCache : TGIFRenderCacheListItem);
|
|
{ Vérifie si "anIndex" ne dépasse pas la nombre d'élément dans la liste. Retroune FALSE si l'index est hors limite }
|
|
{ Check if 'anIndex' does not exceed the number of items in the list. Retrieve FALSE if the index is out of range }
|
|
function IsIndexOk(anIndex : Integer) : Boolean;
|
|
{ Supprime les éléments dont le drapeau "IsCorrupted" est vrai }
|
|
{ Remove items wich "IsCorrupted" flag is on True }
|
|
procedure Pack;
|
|
{ Liste des caches }
|
|
Property Items[Index: Integer]: TGIFRenderCacheListItem read GetItems write SetItems; Default;
|
|
End;
|
|
|
|
{ TGIFAutoStretchMode
|
|
Mode de redimensionnement automatique}
|
|
TGIFAutoStretchMode = (smManual, smStretchAll, smStretchOnlyBigger, smStretchOnlySmaller );
|
|
TOnStretchChanged = procedure (Sender:TObject; IsStretched : Boolean) of object;
|
|
{ TGIFViewer }
|
|
{ Composant visuel pour afficher une image GIF animée }
|
|
{ Visual component for display the animated GIF }
|
|
TGIFViewer = Class(TGraphicControl)
|
|
Private
|
|
FAutoStretchMode: TGIFAutoStretchMode;
|
|
FGIFLoader: TGIFImageLoader;
|
|
FLastDrawMode : TGIFDisposalFlag;
|
|
FFileName: String;
|
|
|
|
FRestoreBitmap, FVirtualView: TFastBitmap;
|
|
|
|
FRenderCache: TGIFRenderCacheList;
|
|
FCurrentFrameIndex: Integer;
|
|
FGIFWidth, FGIFHeight: Integer;
|
|
FCurrentView: Graphics.TBitmap;
|
|
|
|
FAnimateTimer: TTimer;
|
|
FAnimateSpeed: Integer;
|
|
FAnimated, FPause: Boolean;
|
|
FAutoPlay: Boolean;
|
|
FCache: Boolean;
|
|
|
|
FDisplayInvalidFrames : Boolean;
|
|
FAutoRemoveInvalidFrame : Boolean;
|
|
|
|
FPainting: Boolean;
|
|
|
|
FBorderShow: Boolean;
|
|
FBorderColor: TColor;
|
|
FBorderWidth: Byte;
|
|
FBevelInner, FBevelOuter: TPanelBevel;
|
|
FBevelWidth: TBevelWidth;
|
|
FBevelColor, FColor: TColor;
|
|
|
|
FCenter, FStretch, FTransparent: Boolean;
|
|
|
|
FOnStart, FOnStop, FOnPause, FOnFrameChange: TNotifyEvent;
|
|
FOnLoadError : TGIFLoadErrorEvent;
|
|
FOnStretchChanged : TOnStretchChanged;
|
|
|
|
Function GetCanvas: TCanvas;
|
|
Function GetFrameCount: Integer;
|
|
Function GetGIFVersion: String;
|
|
Function GetRawFrameItem(Index : Integer): TGIFImageListItem;
|
|
Procedure SetAutoStretchMode(AValue: TGIFAutoStretchMode);
|
|
Procedure SetCenter(Const Value : Boolean);
|
|
Procedure SetStretch(Const Value : Boolean);
|
|
Procedure SetPause(Const Value : Boolean);
|
|
Procedure SetFileName(Const Value : String);
|
|
Function GetFrame(Const Index : Integer): Graphics.TBitmap;
|
|
Procedure SetTransparent(Const Value : Boolean);
|
|
Procedure SetBevelInner(Const Value : TPanelBevel);
|
|
Procedure SetBevelOuter(Const Value : TPanelBevel);
|
|
Procedure SetBevelWidth(Const Value : TBevelWidth);
|
|
|
|
procedure ResetCurrentView;
|
|
Protected
|
|
Procedure DoInternalOnLoadError(Sender : TObject; Const ErrorCount : Integer; Const ErrorList : TStringList);
|
|
Procedure DoTimerAnimate(Sender : TObject);
|
|
|
|
{ Rendu d'une image de l'animation }
|
|
procedure RenderFrame(Index : Integer); Virtual;
|
|
{ Creation des image cache pour l'animation }
|
|
Procedure ComputeCache; Virtual;
|
|
{ Calcul de la postion et de la dimension pour l'afficchage sur le "Canvas" }
|
|
Function DestRect: TRect; Virtual;
|
|
|
|
{ Fonctions hérités }
|
|
Procedure CalculatePreferredSize(Var PreferredWidth, PreferredHeight : Integer; {%H-}WithThemeSpace : Boolean); Override;
|
|
Class Function GetControlClassDefaultSize: TSize; Override;
|
|
Procedure Paint; Override;
|
|
procedure Loaded; override;
|
|
procedure BeforeLoad;
|
|
procedure AfterLoad;
|
|
Public
|
|
{ Création du composant }
|
|
Constructor Create(AOwner : TComponent); Override;
|
|
{ Destruction du composant }
|
|
Destructor Destroy; Override;
|
|
|
|
{ Mise à jour de la surface de dessin (Canvas) du composant }
|
|
Procedure Invalidate; Override;
|
|
{ LoadFromStream : Charge les données depuis un flux }
|
|
Procedure LoadFromStream(aStream : TStream);
|
|
{ Chargement depuis un fichier }
|
|
Procedure LoadFromFile(Const aFileName : String);
|
|
{ Chargement depuis une Resource Lazarus }
|
|
Procedure LoadFromResource(Const ResName : String);
|
|
{ Joue l'animation }
|
|
Procedure Start;
|
|
{ Arrête l'animation }
|
|
Procedure Stop;
|
|
{ Met en pause l'animation }
|
|
Procedure Pause;
|
|
Procedure NextFrame;
|
|
Procedure PriorFrame;
|
|
{ Retourne l'image brute du GIF à la position Index }
|
|
Function GetRawFrame(Index : Integer): TBitmap;
|
|
{ Affiche l'image de l'animation mise en cache à la position Index }
|
|
Procedure DisplayFrame(Index : Integer);
|
|
{ Affiche l'image brute de l'animation à la position Index }
|
|
Procedure DisplayRawFrame(Index : Integer);
|
|
{ Extrait l'image de l'animation mise en cache à la position Index vers un TBitmap }
|
|
procedure ExtractFrame(Index : Integer; Var bmp:TBitmap) ;
|
|
{ Extrait l'image brute de l'animation à la position Index vers un TBitmap}
|
|
procedure ExtractRawFrame(Index : Integer; Var bmp:TBitmap);
|
|
{ Retourne le Canvas du composant }
|
|
Property Canvas: TCanvas read GetCanvas;
|
|
{ Retourne TRUE si l'animation est en pause }
|
|
Property Paused: Boolean read FPause;
|
|
{ Retourne TRUE si l'animation est en cours }
|
|
Property Playing: Boolean read FAnimated;
|
|
{ Retourne l'index actuel de l'image affichée // Current Index of displayed frame }
|
|
Property CurrentFrameIndex: Integer read FCurrentFrameIndex;
|
|
{ Liste des images de l'animation // List of frame}
|
|
Property Frames[Index: Integer]: TBitmap read GetFrame;
|
|
{ Retourne le nombre d'image de l'animation // Number of frames }
|
|
Property FrameCount: Integer read GetFrameCount;
|
|
{ Retourne la version du fichier GIF chargé // version of the gif }
|
|
Property Version: String read GetGIFVersion;
|
|
{ Image courante de l'animation affichée // Current displayed image }
|
|
Property CurrentView: Graphics.TBitmap read FCurrentView;
|
|
|
|
property RawFrames[Index : Integer] : TGIFImageListItem read GetRawFrameItem;
|
|
Published
|
|
Property Color: TColor read FColor write FColor;
|
|
{ Bordure visible autour du composant // Border visible around component }
|
|
Property Border: Boolean read FBorderShow write FBorderShow;
|
|
{ Couleur de la bordure // Color of border }
|
|
Property BorderColor: TColor read FBorderColor write FBorderColor;
|
|
{ Epaisseur de la bordure // Width of border }
|
|
Property BorderWidth: Byte read FBorderWidth write FBorderWidth;
|
|
|
|
Property BevelColor: TColor read FBevelColor write FBevelColor;
|
|
Property BevelInner: TPanelBevel read FBevelInner write SetBevelInner Default bvNone;
|
|
Property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter Default bvRaised;
|
|
Property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth Default 1;
|
|
|
|
Property Cache: Boolean read FCache write FCache;
|
|
{ Joue l'animation automatiquement lors du chargement d'une image GIF animée }
|
|
{ Play animation automatically when loading an animated GIF image }
|
|
Property AutoPlay: Boolean read FAutoPlay write FAutoPlay;
|
|
{ Affichage du GIF avec prise en charge de la transparence }
|
|
{ GIF view with transparency support }
|
|
Property Transparent: Boolean read FTransparent write SetTransparent;
|
|
{ Centrer l'affichage // Center display }
|
|
Property Center: Boolean read FCenter write SetCenter;
|
|
{ Mode du redimensionnement // Automatic stretch mode
|
|
smManual : Adpatation Manuelle via la propriété stretch
|
|
smStretchAll : Adapte toute les images
|
|
smStretchOnlyBigger : Adapte seulement les images plus grande
|
|
smStretchOnlySmaller : Adapte seulement les images plus petite
|
|
}
|
|
property AutoStretchMode : TGIFAutoStretchMode read FAutoStretchMode write SetAutoStretchMode;
|
|
{ Redimensionner l'affichage proportionnellement // Resize the display proportionally }
|
|
Property Stretch: Boolean read FStretch write SetStretch;
|
|
{ Nom du fichier à charger // Name of file to load }
|
|
Property FileName: String read FFileName write SetFileName;
|
|
{ Définis si les images corrompues doivent être affichées. Si le GIF contient que une seule image ce paramètre n'est pas appliqué. Par defaut FALSE }
|
|
property DisplayInvalidFrames : Boolean read FDisplayInvalidFrames write FDisplayInvalidFrames;
|
|
{ Définis si les images corrompues doivent être effacées de la liste de l'animation automatiquement. Par defaut TRUE }
|
|
property AutoRemoveInvalidFrame : Boolean Read FAutoRemoveInvalidFrame write FAutoRemoveInvalidFrame;
|
|
|
|
{ Evènement déclenché lorsque l'animation débute }
|
|
{ Event triggered when the animation starts }
|
|
Property OnStart: TNotifyEvent read FOnStart write FOnStart;
|
|
{ Evènement déclenché lorsque l'animation s'arrête }
|
|
{ Event triggered when the animation stops }
|
|
Property OnStop: TNotifyEvent read FOnStop write FOnStop;
|
|
{ Evènement déclenché lorsque l'animation est mise en pause }
|
|
{ Event triggered when the animation is paused }
|
|
Property OnPause: TNotifyEvent read FOnPause write FOnPause;
|
|
{ Evènement déclenché lorsque une nouvelle image est affiché lors de l'animation }
|
|
{ Event triggered when a new image is displayed during the animation }
|
|
Property OnFrameChange: TNotifyEvent read FOnFrameChange write FOnFrameChange;
|
|
{ Evenement pour intercepter les erreurs notifiées lors du chargement des données }
|
|
Property OnLoadError: TGIFLoadErrorEvent read FOnLoadError write FOnLoadError;
|
|
{ Evenement pour intercepter le changement du mode stretch. Uniquement si AutoStretchMode <> smManual }
|
|
{ Event to intercept the change of the stretch mode. Only if AutoStretchMode <> smManual }
|
|
property OnStretchChanged : TOnStretchChanged read FOnStretchChanged write FOnStretchChanged;
|
|
|
|
{ Propriétés héritées }
|
|
Property Align;
|
|
Property Anchors;
|
|
Property AutoSize;
|
|
Property Constraints;
|
|
Property BorderSpacing;
|
|
Property Visible;
|
|
Property ParentShowHint;
|
|
Property ShowHint;
|
|
{ Evènements héritées }
|
|
Property OnClick;
|
|
Property OnMouseDown;
|
|
Property OnMouseEnter;
|
|
Property OnMouseLeave;
|
|
Property OnMouseMove;
|
|
Property OnMouseUp;
|
|
Property OnMouseWheel;
|
|
Property OnMouseWheelDown;
|
|
Property OnMouseWheelUp;
|
|
|
|
End;
|
|
|
|
TGIFView = Class(TGIFViewer);
|
|
|
|
Procedure Register;
|
|
|
|
Implementation
|
|
|
|
Uses
|
|
GraphType;
|
|
|
|
{$R ../gifview.res}
|
|
|
|
{%region=====[ Constantes et types internes ]===================================}
|
|
|
|
|
|
Type
|
|
// Statut de décodage / encodage LZW
|
|
TLZWDecoderStatus = (
|
|
dsOK, // Tout va bien
|
|
dsNotEnoughInput, // Tampon d'entrée trop petit
|
|
dsOutputBufferTooSmall, // Tampon de sortie trop petit
|
|
dsInvalidInput, // Donnée corrompue
|
|
dsBufferOverflow, // débordement de tampon
|
|
dsInvalidBufferSize, // Taille d'un des tampons invalide
|
|
dsInvalidInputBufferSize, // Taille du tampon d'entrée invalide
|
|
dsInvalidOutputBufferSize,// Taille du tampon de sortie invalide
|
|
dsInternalError // Erreur interne signifiant qu'il y a un défaut dans le code
|
|
);
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ Fonctions utiles ]===============================================}
|
|
|
|
Function FixPathDelimiter(S : String): String;
|
|
Var
|
|
I: Integer;
|
|
Begin
|
|
Result := S;
|
|
For I := Length(Result) Downto 1 Do
|
|
Begin
|
|
If (Result[I] = '/') Or (Result[I] = '\') Then Result[I] := PathDelim;
|
|
End;
|
|
End;
|
|
|
|
Function CreateFileStream(Const fileName : String; mode : Word = fmOpenRead + fmShareDenyNone): TStream;
|
|
Var
|
|
fn: String;
|
|
Begin
|
|
fn := filename;
|
|
FixPathDelimiter(fn);
|
|
If ((mode And fmCreate) = fmCreate) Or FileExists(fn) Then Result := TFileStream.Create(fn, mode)
|
|
Else
|
|
Raise Exception.Create('Fichier non trouvé : "' + fn + '"');
|
|
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFFastMemoryStream ]==============================================}
|
|
|
|
Constructor TGIFFastMemoryStream.Create(AStream : TStream);
|
|
Var
|
|
ms: TMemoryStream;
|
|
Begin
|
|
ms := TMemoryStream.Create;
|
|
With ms Do
|
|
Begin
|
|
CopyFrom(aStream, 0);
|
|
Position := 0;
|
|
End;
|
|
FSize := ms.Size;
|
|
FPosition := 0;
|
|
FBytesLeft := FSize;
|
|
FBytesRead := 0;
|
|
FBuffer := nil;
|
|
ReAllocMem(FBuffer, FSize);
|
|
Move(PByte(ms.Memory)^, FBuffer^, FSize);
|
|
FreeAndNil(ms);
|
|
End;
|
|
|
|
Destructor TGIFFastMemoryStream.Destroy;
|
|
Begin
|
|
If FBuffer <> nil Then
|
|
Begin
|
|
FreeMem(FBuffer);
|
|
FBuffer := nil;
|
|
End;
|
|
Inherited Destroy;
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.ReadByte: Byte;
|
|
Begin
|
|
Result := 0;
|
|
If FBytesLeft > 0 Then
|
|
Begin
|
|
Result := PByte(FBuffer + FPosition)^;
|
|
Inc(FPosition);
|
|
Inc(FBytesRead);
|
|
Dec(FBytesLeft);
|
|
End;
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.ReadWord: Word;
|
|
Begin
|
|
Result := 0;
|
|
If (FBytesLeft >= 2) Then
|
|
Begin
|
|
Result := PWord(FBuffer + FPosition)^;
|
|
Inc(FPosition, 2);
|
|
Inc(FBytesRead, 2);
|
|
Dec(FBytesLeft, 2);
|
|
End;
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.ReadDWord: DWord;
|
|
Begin
|
|
Result := 0;
|
|
If (FBytesLeft >= 4) Then
|
|
Begin
|
|
Result := PDWord(FBuffer + FPosition)^;
|
|
Inc(FPosition, 4);
|
|
Inc(FBytesRead, 4);
|
|
Dec(FBytesLeft, 4);
|
|
End;
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.Read(Var Buffer; Count : Int64): Int64;
|
|
Var
|
|
NumOfBytesToCopy, NumOfBytesLeft: Longint;
|
|
CachePtr, BufferPtr: PByte;
|
|
Begin
|
|
Result := 0;
|
|
|
|
If (Count > FBytesLeft) Then NumOfBytesLeft := FBytesLeft
|
|
Else
|
|
NumOfBytesLeft := Count;
|
|
|
|
BufferPtr := @Buffer;
|
|
|
|
While NumOfBytesLeft > 0 Do
|
|
Begin
|
|
// On copie les données
|
|
NumOfBytesToCopy := Min(FSize - FPosition, NumOfBytesLeft);
|
|
CachePtr := FBuffer;
|
|
Inc(CachePtr, FPosition);
|
|
|
|
Move(CachePtr^, BufferPtr^, NumOfBytesToCopy);
|
|
Inc(Result, NumOfBytesToCopy);
|
|
Inc(FPosition, NumOfBytesToCopy);
|
|
Inc(BufferPtr, NumOfBytesToCopy);
|
|
// On met à jour les marqueur de notre tampon
|
|
Inc(FBytesRead, NumOfBytesToCopy);
|
|
Dec(FBytesLeft, NumOfBytesToCopy);
|
|
Dec(NumOfBytesLeft, NumOfBytesToCopy);
|
|
|
|
End;
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.Seek(Const Offset : Int64; Origin : TSeekOrigin): Int64;
|
|
Var
|
|
NewPos: Integer;
|
|
Begin
|
|
// Calcul de la nouvelle position
|
|
Case Origin Of
|
|
soBeginning: NewPos := Offset;
|
|
soCurrent: NewPos := FPosition + Offset;
|
|
soEnd: NewPos := pred(FSize) - Offset;
|
|
Else
|
|
Raise Exception.Create('TFastStream.Seek: Origine Invalide');
|
|
End;
|
|
Result := NewPos;
|
|
If Offset = 0 Then exit;
|
|
|
|
FPosition := NewPos;
|
|
FBytesLeft := FSize - FPosition;
|
|
Result := NewPos;
|
|
End;
|
|
|
|
Procedure TGIFFastMemoryStream.SeekForward(Cnt : Integer);
|
|
Begin
|
|
Seek(Cnt, soCurrent);
|
|
End;
|
|
|
|
Function TGIFFastMemoryStream.EOS: Boolean;
|
|
Begin
|
|
Result := ((FBytesLeft <= 0) Or (FPosition >= Pred(FSize)));
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFImageListItem ]==============================================}
|
|
|
|
Constructor TGIFImageListItem.Create;
|
|
Begin
|
|
FBitmap := TFastBitmap.Create;
|
|
FLeft := 0;
|
|
FTop := 0;
|
|
FDelay := 0;
|
|
FDrawMode := dmNone;
|
|
FComment := TStringList.Create;
|
|
FComment.Clear;
|
|
FIsCorrupted := False;
|
|
End;
|
|
|
|
Destructor TGIFImageListItem.Destroy;
|
|
Begin
|
|
FreeAndNil(FComment);
|
|
FreeAndNil(FBitmap);
|
|
Inherited Destroy;
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFImageList ]==================================================}
|
|
|
|
Function TGIFImageList.GetItems(Index : Integer): TGIFImageListItem;
|
|
Begin
|
|
Result := TGIFImageListItem(Inherited Items[Index]);
|
|
End;
|
|
|
|
Procedure TGIFImageList.SetItems(Index : Integer; AGifImage : TGIFImageListItem);
|
|
Begin
|
|
Put(Index, AGifImage);
|
|
End;
|
|
|
|
Procedure TGIFImageList.Clear;
|
|
Var
|
|
anItem: TGIFImageListItem;
|
|
i: Integer;
|
|
Begin
|
|
If Count > 0 Then
|
|
Begin
|
|
For i := Count - 1 Downto 0 do
|
|
Begin
|
|
AnItem := Items[i];
|
|
If anItem <> nil Then anItem.Free;
|
|
End;
|
|
End;
|
|
Inherited Clear;
|
|
End;
|
|
|
|
Function TGIFImageList.AddNewImage: TGIFImageListItem;
|
|
Var
|
|
anItem: TGIFImageListItem;
|
|
Begin
|
|
anitem := TGIFImageListItem.Create;
|
|
Add(anItem);
|
|
Result := Items[Self.Count - 1];
|
|
End;
|
|
|
|
Function TGIFImageList.Add(AGifImage : TGIFImageListItem): Integer;
|
|
Begin
|
|
Result := Inherited Add(AGifImage);
|
|
End;
|
|
|
|
Function TGIFImageList.Extract(Item : TGIFImageListItem): TGIFImageListItem;
|
|
Begin
|
|
Result := TGIFImageListItem(Inherited Extract(Item));
|
|
End;
|
|
|
|
Function TGIFImageList.Remove(AGifImage : TGIFImageListItem): Integer;
|
|
Begin
|
|
Result := Inherited Remove(AGifImage);
|
|
End;
|
|
|
|
Function TGIFImageList.IndexOf(AGifImage : TGIFImageListItem): Integer;
|
|
Begin
|
|
Result := Inherited IndexOf(AGifImage);
|
|
End;
|
|
|
|
Function TGIFImageList.First: TGIFImageListItem;
|
|
Begin
|
|
Result := TGIFImageListItem(Inherited First);
|
|
End;
|
|
|
|
Function TGIFImageList.Last: TGIFImageListItem;
|
|
Begin
|
|
Result := TGIFImageListItem(Inherited Last);
|
|
End;
|
|
|
|
Procedure TGIFImageList.Insert(Index : Integer; AGifImage : TGIFImageListItem);
|
|
Begin
|
|
Inherited Insert(Index, AGifImage);
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFImageLoader ]================================================}
|
|
|
|
Constructor TGIFImageLoader.Create;
|
|
Begin
|
|
Inherited Create;
|
|
FFrames := TGIFImageList.Create(False);
|
|
FErrorList := TStringList.Create;
|
|
FErrorCount := 0;
|
|
FGlobalPalette := nil;
|
|
FTransparent := True;
|
|
FBackgroundColor := clrTransparent;
|
|
End;
|
|
|
|
Destructor TGIFImageLoader.Destroy;
|
|
Begin
|
|
FreeAndNil(FFrames);
|
|
FreeAndNil(FErrorList);
|
|
Inherited Destroy;
|
|
End;
|
|
|
|
Function TGIFImageLoader.CheckFormat(): Boolean;
|
|
Begin
|
|
Result := False;
|
|
// Chargement de l'en-tête
|
|
Memory.Read(FGIFFileHeader, SizeOf(TGIFFileHeader));
|
|
// Vérification de quelques paramètres
|
|
Result := uppercase(String(FGIFFileHeader.Signature)) = 'GIF';
|
|
If Result Then
|
|
Begin
|
|
// Le fichier est valide
|
|
// On sauvegarde la version du GIF
|
|
FVersion := String(FGIFFileHeader.Version);
|
|
If (FVersion = GIFVersions[gv87a]) Or (FVersion = GIFVersions[gv89a]) Then Result := ReadImageProperties // On lit les propriétés
|
|
Else
|
|
Raise Exception.Create(rsUnknownVersion);
|
|
End
|
|
Else
|
|
Begin
|
|
// Signature du fichier GIF Invalide. On lève une exception
|
|
Raise Exception.Create(Format(rsBadSignature,[uppercase(String(FGIFFileHeader.Signature))]));
|
|
End;
|
|
End;
|
|
|
|
Function TGIFImageLoader.ReadImageProperties: Boolean;
|
|
Begin
|
|
Result := False;
|
|
|
|
Memory.Read(FLogicalScreenChunk, SizeOf(TGIFLogicalScreenDescriptorRec));
|
|
|
|
// On sauvegarde en local les dimensions de l'image, pour plus tard
|
|
FWidth := FLogicalScreenChunk.ScreenWidth;
|
|
FHeight := FLogicalScreenChunk.ScreenHeight;
|
|
|
|
If (FWidth < 1) Or (FHeight < 1) Then
|
|
Begin
|
|
// Dimensions incorrectes on lève une exception
|
|
Raise Exception.Create(Format(rsBadScreenSize,[FWidth,FHeight]));
|
|
exit;
|
|
End;
|
|
FHasGlobalPalette := (FLogicalScreenChunk.PackedFields And GIF_GLOBALCOLORTABLE) <> 0;
|
|
|
|
Result := True;
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.AddError(Msg : String);
|
|
Begin
|
|
FErrorList.Add(Msg);
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.NotifyError;
|
|
Begin
|
|
If FErrorList.Count > 0 Then
|
|
Begin
|
|
If Assigned(FOnLoadError) Then FOnLoadError(Self, FErrorList.Count, FErrorList);
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.LoadFromStream(aStream : TStream);
|
|
Begin
|
|
If Memory <> nil Then FreeAndNil(Memory);
|
|
Memory := TGIFFastMemoryStream.Create(aStream);
|
|
If CheckFormat Then LoadFromMemory;
|
|
FreeAndNil(Memory);
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.LoadFromFile(Const FileName : String);
|
|
Var
|
|
Stream: TStream;
|
|
Begin
|
|
FErrorList.Clear;
|
|
FErrorCOunt := 0;
|
|
Stream := CreateFileStream(FileName);
|
|
Try
|
|
LoadFromStream(Stream);
|
|
Finally
|
|
FreeAndNil(Stream);
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.LoadFromResource(Const ResName : String);
|
|
Var
|
|
Stream: TLazarusResourceStream;
|
|
Begin
|
|
FErrorList.Clear;
|
|
FErrorCOunt := 0;
|
|
Stream := TLazarusResourceStream.Create(ResName, nil);
|
|
Try
|
|
LoadFromStream(Stream);
|
|
Finally
|
|
FreeAndNil(Stream);
|
|
End;
|
|
End;
|
|
|
|
Function TGIFImageLoader.GetFrameCount: Integer;
|
|
Begin
|
|
Result := FFrames.Count;
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.SetCurrentLayerIndex(AValue : Integer);
|
|
Begin
|
|
If FCurrentLayerIndex = AValue Then Exit;
|
|
FCurrentLayerIndex := AValue;
|
|
End;
|
|
|
|
Procedure TGIFImageLoader.LoadFromMemory();
|
|
Var
|
|
aRGBColor: TColorRGB24;
|
|
aColor: TColor32;
|
|
PaletteCount: Integer;
|
|
Done: Boolean;
|
|
BlockID: Byte;
|
|
BlockSize: Byte;
|
|
Terminator{%H-}: Byte;
|
|
CurrentLayer: TGIFImageListItem;
|
|
|
|
ImageDescriptor: TGIFImageDescriptorRec;
|
|
GraphicControlExtensionChunk: TGIFGraphicControlExtensionRec;
|
|
ApplicationExtensionChunk: TGIFApplicationExtensionRec;
|
|
NSLoopExtensionChunk: TGIFNSLoopExtensionRec;
|
|
PlainTextChunk: TGIFPlainTextExtensionRec;
|
|
|
|
LocalPalette: TColor32List;
|
|
ColorCount: Integer;
|
|
DMode: Byte;
|
|
ret: TLZWDecoderStatus;
|
|
|
|
{ Chargement palette globale }
|
|
Procedure LoadGlobalPalette;
|
|
Var
|
|
J: Byte;
|
|
Begin
|
|
If FHasGlobalPalette Then
|
|
Begin
|
|
// Remise à zero de la palette globale si elle existe sinon création de celle-ci
|
|
If FGlobalPalette = nil Then FGlobalPalette := TColor32List.Create
|
|
Else
|
|
FGlobalPalette.Clear;
|
|
|
|
PaletteCount := 2 Shl (FLogicalScreenChunk.PackedFields And GIF_COLORTABLESIZE);
|
|
// Le cas ou le nombre de couleurs serait plus grand que 256. On prend en charge.
|
|
If (PaletteCount < 2) Then //or (PaletteCount>256) then
|
|
Raise Exception.Create(rsScreenBadColorSize + ' : ' + IntToStr(PaletteCount));
|
|
|
|
// On charge la palette
|
|
For J := 0 To PaletteCount - 1 Do
|
|
Begin
|
|
Memory.Read(aRGBColor, SizeOF(TColorRGB24));
|
|
aColor.Create(aRGBColor);
|
|
FGlobalPalette.AddColor(aColor);
|
|
End;
|
|
End;
|
|
End;
|
|
|
|
{ Chargement palette locale }
|
|
Procedure LoadLocalPalette;
|
|
Var
|
|
J: Byte;
|
|
Begin
|
|
// Aucune palette locale n'a été assignée. On en créer une nouvelle. Sinon on efface simplement son contenu.
|
|
If LocalPalette = nil Then LocalPalette := TColor32List.Create
|
|
Else
|
|
LocalPalette.Clear;
|
|
|
|
// On verifie que le nombre de couleur dans la palette est correcte
|
|
ColorCount := (2 Shl (ImageDescriptor.PackedFields And GIF_COLORTABLESIZE));
|
|
// Le cas ou le nombre de couleurs serait plus grand que 256. On prend en charge qudn même et on charge la palette.
|
|
If (ColorCount < 2) Then //or (ColorCount>256) then
|
|
Raise Exception.Create(rsImageBadColorSize + ' : ' + IntToStr(ColorCount));
|
|
|
|
// On charge la palette
|
|
For J := 0 To ColorCount - 1 Do
|
|
Begin
|
|
Memory.Read(aRGBColor, SizeOF(TColorRGB24));
|
|
aColor.Create(aRGBColor);
|
|
LocalPalette.AddColor(aColor);
|
|
End;
|
|
End;
|
|
|
|
{ Lecture des extensions }
|
|
Procedure ReadExtension;
|
|
Var
|
|
ExtensionID, BlockType: Byte;
|
|
BufStr: Array[0..255] Of Char;
|
|
Loops: Word;
|
|
CurrentExtension : String;
|
|
Begin
|
|
// On lit les extension jusqu'a ce qu'un bloc de description d'une image soit détecter ou que jusqu'a la fin du fichier
|
|
Repeat
|
|
//showmessage('Read extension at '+ Memory.Position.ToString);
|
|
ExtensionID := Memory.ReadByte;
|
|
CurrentExtension :='';
|
|
// Si c'est un nouveau marqueur d'introduction d'extension. On lit le nouvel ID
|
|
If (ExtensionID = GIF_EXTENSIONINTRODUCER) Then ExtensionID := Memory.ReadByte;
|
|
If (ExtensionID = 0) Then
|
|
Begin
|
|
// On Saute les ID Nul
|
|
Repeat
|
|
ExtensionID := Memory.ReadByte;
|
|
Until (ExtensionID <> 0);
|
|
End;
|
|
Case ExtensionID Of
|
|
GIF_PLAINTEXT:
|
|
Begin
|
|
BlockSize := Memory.ReadByte;
|
|
Memory.Read(PlainTextChunk, SizeOf(TGIFPlainTextExtensionRec));
|
|
Repeat
|
|
// On lit la taille du bloc. Si Zero alors fin des données de l'extension
|
|
BlockSize := Memory.ReadByte;
|
|
// On lit la chaine de caractères
|
|
If (BlockSize > 0) Then
|
|
Begin
|
|
fillchar({%H-}BufStr, 256, 0);
|
|
Memory.Read(BufStr, BlockSize);
|
|
BufStr[BlockSize] := #0;
|
|
// On place le texte dans les commentaires
|
|
CurrentLayer.Comment.Add(String(BufStr));
|
|
End;
|
|
Until (BlockSize = 0);
|
|
// On ajoute une ligne vide de séparation
|
|
CurrentLayer.Comment.Add('');
|
|
End;
|
|
GIF_COMMENTEXTENSION:
|
|
Begin
|
|
Repeat
|
|
// On lit la taille du commentaire. Si Zero alors fin des données de l'extension
|
|
BlockSize := Memory.ReadByte;
|
|
// On lit la chaine de caractères
|
|
If (BlockSize > 0) Then
|
|
Begin
|
|
Memory.Read(BufStr, BlockSize);
|
|
BufStr[BlockSize] := #0;
|
|
// On place le texte dans les commentaires
|
|
CurrentLayer.Comment.Add(String(BufStr));
|
|
End;
|
|
Until (BlockSize <= 0);
|
|
// On ajoute une ligne vide de séparation
|
|
CurrentLayer.Comment.Add('');
|
|
End;
|
|
GIF_APPLICATIONEXTENSION:
|
|
Begin
|
|
|
|
BlockSize := Memory.ReadByte;
|
|
// Certains vieux filtres d'exportation Adobe, ou d'autres logiciels utilisent par erreur une valeur de 10, ou plus petite ou trop grande
|
|
If (BlockSize <> 11) Then
|
|
Begin
|
|
FillChar(ApplicationExtensionChunk, SizeOf(TGIFApplicationExtensionRec), 0);
|
|
End;
|
|
//else if (BlockSize<11) then
|
|
// Raise Exception.Create('Bad extension size' + ' : ' + inttostr(BlockSize) +' octets. ( Taille valide = 11 octets )');
|
|
Memory.Read(ApplicationExtensionChunk, SizeOf(TGIFApplicationExtensionRec));
|
|
CurrentExtension := ApplicationExtensionChunk.AppAuthenticationCode;
|
|
Repeat
|
|
// On lit la taille du bloc. Zero si il n'y a pas de données supplémentaires
|
|
BlockSize := Memory.ReadByte;
|
|
If (BlockSize > 0) Then
|
|
Begin
|
|
if UpperCase(CurrentExtension) = 'NETSCAPE' then
|
|
begin
|
|
BlockType := Memory.ReadByte;
|
|
Dec(BlockSize);
|
|
Case (BlockType And $07) Of
|
|
GIF_LOOPEXTENSION:
|
|
Begin
|
|
// Lecture du nombre de boucle, Si Zero alors boucle infinie
|
|
Loops := Memory.ReadWord;
|
|
If Loops > 0 Then Inc(NSLoopExtensionChunk.Loops);
|
|
Dec(BlockSize, SizeOf(Loops));
|
|
End;
|
|
GIF_BUFFEREXTENSION:
|
|
Begin
|
|
// Lecture de la taille du tampon. Utilisé pour ??????
|
|
NSLoopExtensionChunk.BufferSize := Memory.ReadDWord;
|
|
Dec(BlockSize, SizeOF(NSLoopExtensionChunk.BufferSize));
|
|
End;
|
|
else // Extension NETSCAPE inconnue
|
|
begin
|
|
Memory.SeekForward(BlockSize);
|
|
//BlockSize := 0;
|
|
end;
|
|
End;
|
|
end
|
|
else
|
|
// On saute et on ignore les donnée non lues
|
|
If (BlockSize > 0) Then
|
|
Begin
|
|
Memory.SeekForward(BlockSize);
|
|
//BlockSize := 0;
|
|
End;
|
|
End;
|
|
Until (BlockSize = 0);
|
|
End;
|
|
GIF_GRAPHICCONTROLEXTENSION:
|
|
Begin
|
|
// On lit la taille de l'extension. Normalement 4 Octets. Cette valeur peut-être erronée. On en tient pas compte ici et on lit les données.
|
|
BlockSize := Memory.ReadByte;
|
|
//if BlockSize = 4 then
|
|
//begin
|
|
Memory.Read(GraphicControlExtensionChunk, SizeOf(TGIFGraphicControlExtensionRec));
|
|
// On renseigne notre tampon d'informations pour les prochaines images décodées
|
|
DMode := ((GraphicControlExtensionChunk.PackedFields And GIF_DISPOSAL_ALL) Shr 2);
|
|
With CurrentFrameInfos Do
|
|
Begin
|
|
// Ces valeurs peuvent être utilisées pour plusieurs image. Elles restent valides jusqu'a la lecture du prochain "GCE" trouvé.
|
|
Disposal := TGIFDisposalFlag(DMode);
|
|
IsTransparent := (GraphicControlExtensionChunk.PackedFields And GIF_TRANSPARENT_FLAG) <> 0;
|
|
UserInput := (GraphicControlExtensionChunk.PackedFields And GIF_USER_INPUT_FLAG) <> 0;
|
|
TransparentColorIndex := GraphicControlExtensionChunk.TransparentColorIndex;
|
|
BackgroundColorIndex := FLogicalScreenChunk.BackgroundColorIndex;
|
|
DelayTime := GraphicControlExtensionChunk.DelayTime;
|
|
End;
|
|
// Lecture de l'octet de fin de l'extension
|
|
Terminator := Memory.ReadByte;
|
|
End;
|
|
End;
|
|
Until (ExtensionID = GIF_IMAGEDESCRIPTOR) Or Memory.EOS;
|
|
|
|
// Si l'ID pour la description de l'image est détecter on revient en arrière pour la prise en charge par le traitement des données
|
|
If (ExtensionID = GIF_IMAGEDESCRIPTOR) Then Memory.Seek(-1, soCurrent);
|
|
End;
|
|
|
|
{ Chargement d'une image }
|
|
Procedure LoadImage;
|
|
Var
|
|
DecoderStatus{%H-}: TLZWDecoderStatus;
|
|
BufferSize, TargetBufferSize, BytesRead: Int64;
|
|
InitCodeSize: Byte;
|
|
OldPosition: Int64;
|
|
Buffer, BufferPtr: PByte;
|
|
TargetBuffer, TargetBufferPtr: PByte;
|
|
LinePtr: PColor32;
|
|
Pass, Increment: Byte;
|
|
x: Integer;
|
|
TargetColor: TColor32;
|
|
ColIdx: Byte;
|
|
CurrentLine: Integer;
|
|
OutBmp: TFastBitmap;
|
|
|
|
// Decodeur GIF LZW. Basé sour le code source de la bibliothèque GraphicEX pour Delphi
|
|
Function DecodeLZW(Var Source, Dest : Pointer; PackedSize, UnpackedSize : Integer): TLZWDecoderStatus;
|
|
Const
|
|
{ Constantes pour la décompression LZW }
|
|
_LZWGIFCodeBits = 12; // Nombre maximal de bits par code d'un jeton (12 bits = 4095)
|
|
_LZWGIFCodeMax = 4096; // Nombre maximum de jeton
|
|
_LZWGIFStackSize = (2 Shl _LZWGIFCodeBits); // Taille de la pile de décompression
|
|
_LZWGIFTableSize = (1 Shl _LZWGIFCodeBits); // Taille de la table de décompression
|
|
|
|
Var
|
|
J: Integer;
|
|
Data, // Données actuelle
|
|
Bits, // Compteur de bit
|
|
Code: Cardinal; // Valeur courrante du Code
|
|
SourcePtr: PByte;
|
|
InCode: Cardinal; // Tampon pour passé le Code
|
|
|
|
CodeSize: Cardinal;
|
|
CodeMask: Cardinal;
|
|
FreeCode: Cardinal;
|
|
OldCode: Cardinal;
|
|
Prefix: Array[0.._LZWGIFTableSize] Of Cardinal; // LZW prefix
|
|
Suffix, // LZW suffix
|
|
Stack: Array [0.._LZWGIFStackSize] Of Byte;
|
|
StackPointer: PByte;
|
|
MaxStackPointer: PBYte;
|
|
Target: PByte;
|
|
FirstChar: Byte; // Tampon de décodage d'un octet
|
|
ClearCode, EOICode: Word;
|
|
MaxCode: Boolean;
|
|
|
|
Begin
|
|
Result := dsOk;
|
|
DecoderStatus := dsOk;
|
|
If (PackedSize <= 0) Or (UnpackedSize <= 0) Then
|
|
Begin
|
|
// Taille des tampons invalides
|
|
If (PackedSize <= 0) And (UnpackedSize <= 0) Then Result := dsInvalidBufferSize
|
|
Else If PackedSize <= 0 Then Result := dsInvalidInputBufferSize
|
|
Else If UnpackedSize <= 0 Then Result := dsInvalidOutputBufferSize;
|
|
Exit;
|
|
End;
|
|
|
|
// Initialisation des paramètres pour la décompression
|
|
CodeSize := InitCodeSize + 1;
|
|
ClearCode := 1 Shl InitCodeSize;
|
|
EOICode := ClearCode + 1;
|
|
FreeCode := ClearCode + 2;
|
|
OldCode := _LZWGIFCodeMax - 1;
|
|
CodeMask := (1 Shl CodeSize) - 1;
|
|
MaxCode := False;
|
|
Code := 0;
|
|
Target := PByte(Dest);
|
|
SourcePtr := PByte(Source);
|
|
|
|
// Initialisation des tables de Code
|
|
For J := 0 To _LZWGIFTableSize Do
|
|
Begin
|
|
Prefix[J] := _LZWGIFCodeMax;
|
|
Suffix[J] := J;
|
|
End;
|
|
|
|
// Initalisation de la pile
|
|
StackPointer := @Stack;
|
|
MaxStackPointer := @Stack[_LZWGIFStackSize];
|
|
FirstChar := 0;
|
|
|
|
Data := 0;
|
|
Bits := 0;
|
|
While (UnpackedSize > 0) And (PackedSize > 0) Do
|
|
Begin
|
|
// On lit le "Code" dans le tampon d'entrée
|
|
Inc(Data, SourcePtr^ Shl Bits);
|
|
Inc(Bits, 8);
|
|
While (Bits > CodeSize) And (UnpackedSize > 0) Do
|
|
Begin
|
|
// Code actuel
|
|
Code := Data And CodeMask;
|
|
// Préparation pour la donnée suivante
|
|
Data := Data Shr CodeSize;
|
|
Dec(Bits, CodeSize);
|
|
|
|
// Décompression finie ?
|
|
If Code = EOICode Then
|
|
Begin
|
|
// Si nous arrivons ici, il y a probablement quelque chose de suspect avec l'image GIF
|
|
// Car normalement on stoppe dès que le tampon de sortie est plein.
|
|
// Cela signifie que nous ne lirons jamais l'EOICode de fermeture dans les images normales.
|
|
// Comme l'état du buffer est déjà vérifié après la boucle principale, nous ne le ferons pas ici.
|
|
Break;
|
|
End;
|
|
|
|
// On vérifie s'il s'agit d'un code valide déjà enregistré
|
|
If Code > FreeCode Then
|
|
Begin
|
|
// Code ne peux à être supérieur à FreeCode. Nous avons donc une image cassée.
|
|
// On notifie l'erreur à l'utilisateur. Et on considère qu'il n'ya pas d'erreur.
|
|
DecoderStatus := dsInvalidInput;
|
|
AddError(Format(rsLZWInvalidInput,[CurrentFrameIndex]));
|
|
//NotifyUser('Le décodeur a rencontré une entrée invalide (données corrompues)');
|
|
Code := ClearCode;
|
|
//Break; //Ici, on continue le chargement du reste de l'image au lieu de le stopper
|
|
End;
|
|
|
|
// RAZ
|
|
If Code = ClearCode Then
|
|
Begin
|
|
// réinitialisation de toutes les variables
|
|
CodeSize := InitCodeSize + 1;
|
|
CodeMask := (1 Shl CodeSize) - 1; //CodeMasks[CodeSize];
|
|
FreeCode := ClearCode + 2;
|
|
OldCode := _LZWGIFCodeMax;
|
|
MaxCode := False;
|
|
End
|
|
Else If OldCode = _LZWGIFCodeMax Then
|
|
Begin
|
|
// Gestion du premier Code LZW : On le définit dans le tampon de sortie et on le conserve
|
|
FirstChar := Suffix[Code];
|
|
Target^ := FirstChar;
|
|
Inc(Target);
|
|
Dec(UnpackedSize);
|
|
OldCode := Code;
|
|
End
|
|
Else
|
|
Begin
|
|
//On conserve le Code LZW actuel
|
|
InCode := Code;
|
|
|
|
// On place le nouveau code LZW sur la pile sauf quand nous avons déjà utilisé tous les codes disponibles
|
|
If (Code = FreeCode) And Not MaxCode Then
|
|
Begin
|
|
StackPointer^ := FirstChar;
|
|
Inc(StackPointer);
|
|
Code := OldCode;
|
|
End;
|
|
|
|
// boucle pour placer les octets décodés sur la pile
|
|
While Code > ClearCode Do
|
|
Begin
|
|
StackPointer^ := Suffix[Code];
|
|
If StackPointer >= MaxStackPointer Then
|
|
Begin
|
|
// Ne doit jamais arriver, c'est juste une précaution au cas ou.
|
|
Result := dsBufferOverflow;
|
|
break;
|
|
End;
|
|
Inc(StackPointer);
|
|
Code := Prefix[Code];
|
|
End;
|
|
If Result <> dsOK Then break; // Si il ya eu des erreurs on ne va pas plus loin
|
|
|
|
// Place le nouveau Code dans la table
|
|
FirstChar := Suffix[Code];
|
|
StackPointer^ := FirstChar;
|
|
Inc(StackPointer);
|
|
|
|
//Transfert des données décodées vers notre tampon de sortie
|
|
Repeat
|
|
If UnpackedSize <= 0 Then
|
|
Begin
|
|
// Le tampon de sortie est trop petit. On ne va pas plus loin
|
|
// On notifie l'erreur à l'utilisateur. Et on considère qu'il n'ya pas d'erreur.
|
|
// Afin de pouvoir afficher le GIF et continuer le chargement des images suivantes
|
|
Result := dsOutputBufferTooSmall;
|
|
AddError(Format(rsLZWOutputBufferTooSmall,[CurrentFrameIndex]));
|
|
break;
|
|
End;
|
|
Dec(StackPointer);
|
|
Target^ := StackPointer^;
|
|
Inc(Target);
|
|
Dec(UnpackedSize);
|
|
Until StackPointer = @Stack;
|
|
If Result <> dsOK Then break;
|
|
|
|
If Not MaxCode Then
|
|
Begin
|
|
If FreeCode <= _LZWGIFCodeMax Then
|
|
Begin
|
|
Prefix[FreeCode] := OldCode;
|
|
Suffix[FreeCode] := FirstChar;
|
|
End
|
|
Else If FreeCode > _LZWGIFCodeMax Then
|
|
Begin
|
|
// On a intercepter une donnée corrompue. On continue quand la même décompression sans en tenir compte.
|
|
// On notifie juste l'erreur à l'utilisateur
|
|
DecoderStatus := dsInvalidInput;
|
|
AddError(Format(rsLZWInvalidInput,[CurrentFrameIndex]));
|
|
FreeCode := _LZWGIFCodeMax;
|
|
Prefix[FreeCode] := OldCode;
|
|
Suffix[FreeCode] := FirstChar;
|
|
//MaxCode := True;
|
|
End;
|
|
|
|
// On augmente la taille du Code si nécessaire
|
|
If (FreeCode = CodeMask) And Not (MaxCode) Then
|
|
Begin
|
|
If (CodeSize < _LZWGIFCodeBits) Then
|
|
Begin
|
|
Inc(CodeSize);
|
|
CodeMask := (1 Shl CodeSize) - 1;//CodeMasks[CodeSize];
|
|
End
|
|
Else //On a atteind la limite maximum
|
|
MaxCode := True;
|
|
End;
|
|
|
|
If FreeCode < _LZWGIFTableSize Then Inc(FreeCode);
|
|
End;
|
|
OldCode := InCode;
|
|
End;
|
|
End;
|
|
Inc(SourcePtr);
|
|
Dec(PackedSize);
|
|
If (Result <> dsOK) Or (Code = EOICode) Then Break;
|
|
End;
|
|
|
|
If Result = dsOK Then
|
|
Begin
|
|
// On vérifie seulement si il n'ya pas eu d'erreur. Si ce n'est pas le cas, nous savons déjà que quelque chose ne va pas.
|
|
// Notez qu'il est normal que PackedSize soit un peu> 0 parce que nous pouvons
|
|
// pas lire l'EOICode mais arrêter dès que notre tampon de sortie est plein et
|
|
// qui devrait normalement être le code juste avant l'EOICode.
|
|
If PackedSize < 0 Then
|
|
Begin
|
|
Result := dsInternalError;
|
|
// C'est une erreur sérieuse : nous avons eu un dépassement de tampon d'entrée que nous aurions dû intercepter. Nous devons arrêter maintenant.
|
|
Raise Exception.Create(rsLZWInternalErrorInputBufferOverflow);
|
|
Exit;
|
|
End;
|
|
If UnpackedSize <> 0 Then
|
|
Begin
|
|
//if UnpackedSize > 0 then
|
|
//begin
|
|
// // Image corrompue
|
|
// DecoderStatus := dsNotEnoughInput;
|
|
// AddError('Image #'+CurrentFrameIndex)+' : Le décodeur n''a pas pu décoder toutes les données car le tampon d''entrée est trop petit');
|
|
// //NotifyUser('Le décodeur n''a pas pu décoder toutes les données car le tampon d''entrée est trop petit');
|
|
//End
|
|
//else
|
|
If UnpackedSize < 0 Then
|
|
Begin
|
|
Result := dsInternalError;
|
|
// C'est une erreur sérieuse : nous avons eu un dépassement de tampon de sortie que nous aurions dû intercepter. Nous devons arrêter maintenant.
|
|
Raise Exception.Create(rsLZWInternalErrorOutputBufferOverFlow);
|
|
End;
|
|
End;
|
|
End;
|
|
End;
|
|
|
|
Begin
|
|
BufferSize := 0;
|
|
TargetBufferSize := 0;
|
|
|
|
// On lit la description de l'image
|
|
Memory.Read(ImageDescriptor, SizeOf(TGIFImageDescriptorRec));
|
|
|
|
// On vérifie que les dimensions sont correctes.
|
|
// Si on trouve des dimensions à zero, il se peut qu'il faudra traiter
|
|
// une extension PlainText et dessiner ce texte en fonction des paramètres
|
|
If (ImageDescriptor.Height = 0) Or (ImageDescriptor.Width = 0) Then
|
|
Begin
|
|
// On assigne les dimensions par défaut du GIF
|
|
ImageDescriptor.Width := FLogicalScreenChunk.ScreenWidth;
|
|
ImageDescriptor.Height := FLogicalScreenChunk.ScreenHeight;
|
|
// On notifie à l'utilisateur que les dimensions de l'image sont erronée. Mais on tente le chargement quand même
|
|
// ShowMessage
|
|
End;
|
|
|
|
// Dans le cas ou les dimensions de l'image sont incorrectes dans "l'image descriptor". Ou que la taille des données compressées soit erronée.
|
|
If (ImageDescriptor.Width > FLogicalScreenChunk.ScreenWidth) Or (ImageDescriptor.Height > FLogicalScreenChunk.ScreenHeight) Then
|
|
Begin
|
|
// On assigne les dimensions par défaut du GIF
|
|
If (ImageDescriptor.Width > FLogicalScreenChunk.ScreenWidth) Then ImageDescriptor.Width := FLogicalScreenChunk.ScreenWidth;
|
|
If (ImageDescriptor.Height > FLogicalScreenChunk.ScreenHeight) Then ImageDescriptor.Height := FLogicalScreenChunk.ScreenHeight;
|
|
// On notifie à l'utilisateur que les dimensions de l'image sont erronée. Mais on tente le chargement quand même
|
|
// ShowMessage
|
|
End;
|
|
|
|
// On renseigne notre tampon d'informations
|
|
With CurrentFrameInfos Do
|
|
Begin
|
|
Left := ImageDescriptor.Left;
|
|
Top := ImageDescriptor.Top;
|
|
Width := ImageDescriptor.Width;
|
|
Height := ImageDescriptor.Height;
|
|
Interlaced := (ImageDescriptor.PackedFields And GIF_INTERLACED) = GIF_INTERLACED;
|
|
HasLocalPalette := (ImageDescriptor.PackedFields And GIF_LOCALCOLORTABLE) = GIF_LOCALCOLORTABLE;
|
|
End;
|
|
|
|
// L'image possède-t-elle sa propre palette de couleur ? Si oui on la charge.
|
|
If CurrentFrameInfos.HasLocalPalette Then LoadLocalPalette;
|
|
|
|
// Decompression de l'image
|
|
|
|
// On ajoute une nouvelle image si besoin
|
|
If (FCurrentLayerIndex > 0) And (FCurrentLayerIndex > FFrames.Count - 1) Then CurrentLayer := FFrames.AddNewImage;
|
|
// On assigne la nouvelle image au Bitmap de travail
|
|
OutBmp := FFrames.Items[CurrentFrameIndex].Bitmap;
|
|
|
|
// On met à jour les informations
|
|
With FFrames.Items[FCurrentLayerIndex] Do
|
|
Begin
|
|
Drawmode := CurrentFrameInfos.Disposal;
|
|
// Showmessage('#'+inttostr(FCurrentLayerIndex) + 'DrawMode : '+ GifGCEDisposalModeStr[Drawmode]);
|
|
Left := CurrentFrameInfos.Left;
|
|
Top := CurrentFrameInfos.Top;
|
|
IsTransparent := CurrentFrameInfos.IsTransparent;
|
|
If CurrentFrameInfos.DelayTime = 0 Then Delay := GIF_DefaultDelay
|
|
Else
|
|
Delay := CurrentFrameInfos.DelayTime * GIF_DelayFactor;
|
|
End;
|
|
|
|
// On lit le code d'initalisation de la compression LZW
|
|
InitCodeSize := Memory.ReadByte;
|
|
If InitCodeSize < 2 Then InitCodeSize := 2;
|
|
If InitCodeSize > 8 Then InitCodeSize := 8;
|
|
|
|
// On sauve la position actuelle dans le flux
|
|
OldPosition := Memory.position;
|
|
|
|
BufferSize := 0;
|
|
|
|
// 1) On comptabilise la taille totale des données compresser. Afin de les décompresser en une seule fois.
|
|
// On lit la taille du premier bloc
|
|
BlockSize := Memory.ReadByte;
|
|
While (BlockSize > 0) And Not (Memory.EOS) Do
|
|
Begin
|
|
Inc(BufferSize, BlockSize);
|
|
// On saute les données
|
|
Memory.SeekForward(BlockSize);
|
|
If Not (Memory.EOS) Then BlockSize := Memory.ReadByte
|
|
Else
|
|
blocksize := 0;
|
|
End;
|
|
|
|
// 2) On initalise notre bitmap avec les bonnes dimensions
|
|
OutBmp.SetSize(CurrentFrameInfos.Width, CurrentFrameInfos.Height);
|
|
|
|
BufferPtr := nil;
|
|
Buffer := nil;
|
|
// 3) On alloue notre tampon pour les données compressées
|
|
If (BufferSize > 0) Then Reallocmem(Buffer, BufferSize);
|
|
|
|
// 4) On charge toutes les données dans notre tampon
|
|
// On se replace au début des données
|
|
Memory.Seek(OldPosition, soBeginning);
|
|
// On travail toujours sur une copie du "pointer"
|
|
BufferPtr := Buffer;
|
|
// On lit la taille du premier bloque
|
|
BlockSize := Memory.ReadByte;
|
|
While (BlockSize > 0) And Not (Memory.EOS) Do
|
|
Begin
|
|
// On charge les données dans le tampon. On previent des erreurs en cas de dépassements
|
|
BytesRead := Memory.Read(BufferPtr^, BlockSize);
|
|
Inc(BufferPtr, BytesRead);
|
|
If Not (Memory.EOS) Then BlockSize := Memory.ReadByte
|
|
Else
|
|
blocksize := 0;
|
|
End;
|
|
// On se replace au debut du tampon
|
|
BufferPtr := Buffer;
|
|
// 5) On decompresse les données
|
|
// On initialise notre buffer ou seront décompressées les données
|
|
TargetBufferSize := Int64(CurrentFrameInfos.Width) * Int64(CurrentFrameInfos.Height);
|
|
TargetBufferPtr := nil;
|
|
TargetBuffer := nil;
|
|
// Si la taille est plus grande que zero, on alloue l'espace nécessaire à notre tampon
|
|
If (TargetBufferSize > 0) Then Reallocmem(TargetBuffer, TargetBufferSize);
|
|
|
|
// Décodage des données compressées
|
|
Ret := DecodeLZW(Buffer, TargetBuffer, BufferSize, TargetBufferSize);
|
|
|
|
// 6) On transfert les données de l'image vers notre bitmap. Si il n'y a pas eu d'erreurs
|
|
If (Ret = dsOk) Then
|
|
Begin
|
|
TargetBufferPtr := TargetBuffer;
|
|
OutBmp.Clear(clrTransparent);
|
|
|
|
// Image non entrelacée
|
|
If Not (CurrentFrameInfos.Interlaced) Then
|
|
Begin
|
|
CurrentLine := 0;
|
|
While (CurrentLine <= CurrentFrameInfos.Height - 1) Do
|
|
Begin
|
|
LinePtr := OutBmp.GetScanLine(CurrentLine);// FFrames.Items[CurrentFrameIndex].Bitmap.GetScanLine(CurrentLine);
|
|
For x := 0 To (CurrentFrameInfos.Width - 1) Do
|
|
Begin
|
|
// Lecture de l'index de la couleur dans la palette
|
|
ColIdx := TargetBufferPtr^;
|
|
// On utilise la palette de couleur locale
|
|
If CurrentFrameInfos.HasLocalPalette Then
|
|
Begin
|
|
If LocalPalette <> nil Then // La palette est-elle chargée ?
|
|
Begin
|
|
//if (ColIdx> ColorCount-1) then ColIdx := ColorCount -1;
|
|
If (ColIdx < ColorCount) Then TargetColor := LocalPalette.Colors[ColIdx].Value
|
|
Else
|
|
TargetColor := clrTransparent;
|
|
End
|
|
Else If FGlobalPalette <> nil Then // Non, alors on utilise la palette globale si elle est présente
|
|
Begin
|
|
//if (ColIdx> PaletteCount-1) then ColIdx := PaletteCount -1;
|
|
If (ColIdx < PaletteCount) Then TargetColor := FGlobalPalette.Colors[ColIdx].Value
|
|
Else
|
|
TargetColor := clrTransparent;
|
|
End
|
|
Else
|
|
Begin
|
|
AddError(rsEmptyColorMap);
|
|
Exit;
|
|
End;
|
|
End
|
|
Else // On utilise la palette de couleur globale
|
|
Begin
|
|
If FGlobalPalette <> nil Then
|
|
Begin
|
|
//if (ColIdx> PaletteCount-1) then ColIdx := PaletteCount -1;
|
|
If (ColIdx < PaletteCount) Then TargetColor := FGlobalPalette.Colors[ColIdx].Value
|
|
Else
|
|
TargetColor := clrTransparent;
|
|
End
|
|
Else If LocalPalette <> nil Then
|
|
Begin
|
|
//if (ColIdx> ColorCount-1) then ColIdx := ColorCount -1;
|
|
If (ColIdx > ColorCount - 1) Then //ColIdx := ColorCount -1;
|
|
TargetColor := LocalPalette.Colors[ColIdx].Value
|
|
Else
|
|
TargetColor := clrTransparent;
|
|
End
|
|
Else
|
|
Begin
|
|
AddError(rsEmptyColorMap);
|
|
Exit;
|
|
End;
|
|
End;
|
|
|
|
If CurrentFrameInfos.IsTransparent Then
|
|
Begin
|
|
If FHasGlobalPalette Then If ColIdx < FGlobalPalette.Count Then OutBmp.TransparentColor := FGlobalPalette.Colors[ColIdx].Value.ToColor
|
|
Else If ColIdx < LocalPalette.Count Then OutBmp.TransparentColor := LocalPalette.Colors[ColIdx].Value.ToColor;
|
|
|
|
If (Self.FTransparent) Then
|
|
Begin
|
|
If (ColIdx = CurrentFrameInfos.TransparentColorIndex) Then
|
|
begin
|
|
TargetColor.Alpha := 0; // clrTransparent;
|
|
end;
|
|
If (CurrentFrameInfos.TransparentColorIndex = CurrentFrameInfos.BackgroundColorIndex) Then FbackgroundColor.Alpha := 0; //clrTransparent;
|
|
End;
|
|
End;
|
|
LinePtr^ := TargetColor;
|
|
// On avance de 1 élément dans nos "pointer"
|
|
Inc(TargetBufferPtr);
|
|
Inc(LinePtr);
|
|
End;
|
|
Inc(CurrentLine);
|
|
End;
|
|
End
|
|
Else // Image entrelacée
|
|
Begin
|
|
CurrentLine := 0;
|
|
For pass := 0 To 3 Do
|
|
Begin
|
|
Case Pass Of
|
|
0:
|
|
Begin
|
|
CurrentLine := 0;
|
|
Increment := 8;
|
|
End;
|
|
1:
|
|
Begin
|
|
CurrentLine := 4;
|
|
Increment := 8;
|
|
End;
|
|
2:
|
|
Begin
|
|
CurrentLine := 2;
|
|
Increment := 4;
|
|
End;
|
|
Else
|
|
Begin
|
|
CurrentLine := 1;
|
|
Increment := 2;
|
|
End;
|
|
End;
|
|
While (CurrentLine < CurrentFrameInfos.Height) Do
|
|
Begin
|
|
LinePtr :=OutBmp.GetScanLine(CurrentLine); // FFrames.Items[CurrentFrameIndex].Bitmap
|
|
For x := 0 To (FFrames.Items[CurrentFrameIndex].Bitmap.Width - 1) Do
|
|
Begin
|
|
// Lecture de l'index de la couleur dans la palette
|
|
ColIdx := TargetBufferPtr^;
|
|
// On utilise la palette de couleur locale
|
|
If CurrentFrameInfos.HasLocalPalette Then
|
|
Begin
|
|
If LocalPalette <> nil Then // La palette est-elle chargée ?
|
|
Begin
|
|
If (ColIdx < ColorCount) Then // Dans le cas contraire il s'agit d'un index pour la transparence
|
|
TargetColor := LocalPalette.Colors[ColIdx].Value;
|
|
End
|
|
Else If FGlobalPalette <> nil Then // Non, alors on utilise la palette globale si elle est présente
|
|
Begin
|
|
If (ColIdx < PaletteCount) Then //if (ColIdx< PaletteCount-1) then ColIdx := PaletteCount -1;
|
|
TargetColor := FGlobalPalette.Colors[ColIdx].Value;
|
|
End
|
|
Else
|
|
Begin
|
|
AddError(rsEmptyColorMap);
|
|
Exit;
|
|
End;
|
|
End
|
|
Else // On utilise la palette de couleur globale
|
|
Begin
|
|
If FGlobalPalette <> nil Then
|
|
Begin
|
|
If (ColIdx > PaletteCount - 1) Then ColIdx := PaletteCount - 1;
|
|
TargetColor := FGlobalPalette.Colors[ColIdx].Value;
|
|
End
|
|
Else If LocalPalette <> nil Then
|
|
Begin
|
|
If (ColIdx > ColorCount - 1) Then ColIdx := ColorCount - 1;
|
|
TargetColor := LocalPalette.Colors[ColIdx].Value;
|
|
End
|
|
Else
|
|
Begin
|
|
AddError(rsEmptyColorMap);
|
|
Exit;
|
|
End;
|
|
End;
|
|
|
|
If CurrentFrameInfos.IsTransparent Then
|
|
Begin
|
|
If FHasGlobalPalette Then If ColIdx < FGlobalPalette.Count Then OutBmp.TransparentColor := FGlobalPalette.Colors[ColIdx].Value.ToColor
|
|
Else If ColIdx < LocalPalette.Count Then OutBmp.TransparentColor := LocalPalette.Colors[ColIdx].Value.ToColor;
|
|
If (FTransparent) Then
|
|
Begin
|
|
If CurrentFrameInfos.TransparentColorIndex = colIdx Then
|
|
begin
|
|
TargetColor.Alpha := 0; // := clrTransparent;
|
|
End;
|
|
If (CurrentFrameInfos.TransparentColorIndex = CurrentFrameInfos.BackgroundColorIndex) Then FBackgroundColor.Alpha := 0;
|
|
End;
|
|
End;
|
|
|
|
LinePtr^ := TargetColor;
|
|
Inc(TargetBufferPtr);
|
|
If (CurrentLine < CurrentFrameInfos.Height - 1) Then Inc(LinePtr);
|
|
End;
|
|
Inc(CurrentLine, Increment);
|
|
End;
|
|
End;
|
|
End;
|
|
if DecoderStatus <> dsOk then
|
|
begin
|
|
//outBmp.Clear(ClrTransparent);
|
|
FFrames.Items[FCurrentLayerIndex].IsCorrupted := True;
|
|
FFrames.Items[FCurrentLayerIndex].Delay:= 1;
|
|
End;
|
|
Inc(FCurrentLayerIndex); // Index pour la prochaine image
|
|
End
|
|
Else
|
|
Begin
|
|
Case Ret Of
|
|
dsInvalidBufferSize: AddError(Format(rsInvalidBufferSize,[CurrentFrameIndex]));
|
|
dsInvalidInputBufferSize: AddError(Format(rsInvalidInputBufferSize,[CurrentFrameIndex]));
|
|
dsInvalidOutputBufferSize: AddError(Format(rsInvalidOutputBufferSize,[CurrentFrameIndex]));
|
|
dsBufferOverflow: AddError(Format(rsBufferOverFlow,[CurrentFrameIndex]));
|
|
dsOutputBufferTooSmall :
|
|
(* begin
|
|
// On supprime l'image. Le tampon de sortie étant trop petit, cela va générer des erreurs lors du transfert des données décompressées vers l'image
|
|
//FFrames.Delete(CurrentFrameIndex);
|
|
|
|
end;*)
|
|
dec(FCurrentLayerIndex);
|
|
|
|
End;
|
|
if Ret<>dsOutputBufferTooSmall then
|
|
begin
|
|
FFrames.Items[FCurrentLayerIndex].IsCorrupted := True;
|
|
FFrames.Items[FCurrentLayerIndex].Delay:= 1;
|
|
end;
|
|
End;
|
|
|
|
// On libére la mémoire allouée pour nos tampons
|
|
If (TargetBufferSize > 0) And (targetBuffer <> nil) Then FreeMem(TargetBuffer);
|
|
If (BufferSize > 0) And (Buffer <> nil) Then FreeMem(Buffer);
|
|
End;
|
|
|
|
Begin
|
|
PaletteCount := 0;
|
|
ColorCount := 0;
|
|
LocalPalette := nil;
|
|
FFrames.Clear;
|
|
|
|
// Par defaut, on considère que la couleur de fond est totalement transparente
|
|
FBackgroundColor := clrTransparent;
|
|
// Si une palette globale existe, alors on charge
|
|
LoadGlobalPalette;
|
|
If FHasGlobalPalette Then
|
|
Begin
|
|
If FLogicalScreenChunk.BackgroundColorIndex < PaletteCount - 1 Then FBackgroundColor := FGlobalPalette.Colors[FLogicalScreenChunk.BackgroundColorIndex].Value
|
|
Else
|
|
Begin
|
|
FBackgroundColor := clrTransparent; //FGlobalPalette.Colors[FLogicalScreenChunk.BackgroundColorIndex].Value;
|
|
End;
|
|
End;
|
|
|
|
// Les valeurs suivante seront renseignées lors du chargement d'une image
|
|
// On réinitialise juste les valeurs par défaut des informations de l'image en cours au cas ou il n'y aurait pas de GCE
|
|
With CurrentFrameInfos Do
|
|
Begin
|
|
Left := 0;
|
|
Top := 0;
|
|
Width := FLogicalScreenChunk.ScreenWidth;
|
|
Height := FLogicalScreenChunk.ScreenHeight;
|
|
Interlaced := False;
|
|
HasLocalPalette := False;
|
|
IsTransparent := False;
|
|
End;
|
|
// On ajoute l'image de départ afin de pouvoir assigner les valeurs des premières extensions (Extensions déclarées avant l'image)
|
|
CurrentLayer := FFrames.AddNewImage;
|
|
// On efface l'image avec la couleur de fond
|
|
//CurrentLayer.Bitmap.Clear(FBackgroundColor);
|
|
FCurrentLayerIndex := 0;
|
|
// On lit le 1er octet
|
|
Done := False;
|
|
While Not (Done) Do
|
|
Begin
|
|
// On verifie l'existence d'extensions avant les données de l'image (Application, Graphic Control, PlainText, Comment)
|
|
If Not (Memory.EOS) Then BlockID := Memory.ReadByte
|
|
Else
|
|
BlockID := GIF_Trailer;
|
|
If (BlockID = GIF_Trailer) Then
|
|
Begin
|
|
Done := True;
|
|
End;
|
|
If (BlockID = 0) Then
|
|
Begin
|
|
// On Saute les ID Nul
|
|
While (BlockId = 0) Do BlockId := Memory.ReadByte;
|
|
End
|
|
Else If (BlockID = GIF_IMAGEDESCRIPTOR) Then // C'est une image
|
|
Begin
|
|
// On charge l'image
|
|
LoadImage;
|
|
End
|
|
Else If (BlockID = GIF_EXTENSIONINTRODUCER) Then // c'est une extension
|
|
Begin
|
|
ReadExtension; // On charge toutes les extensions qui sont à la suite
|
|
End
|
|
Else
|
|
Begin
|
|
// Extension inconnue on saute jusqu'a trouver un ZERO.
|
|
// A Verifier avec le flag UseInput dans le "Graphic Control Extension"
|
|
// Ici on ignore simplement les données
|
|
While BlockID <> 0 Do
|
|
Begin
|
|
BlockID := Memory.ReadByte;
|
|
End;
|
|
End;
|
|
End;
|
|
// Si il y a des erreurs elles seront notifier à l'utilisateur
|
|
NotifyError;
|
|
|
|
// Il n'y a aucune images on notifie l'erreur
|
|
If FFrames.Count = 0 Then Raise Exception.Create(rsEmptyImage);
|
|
|
|
// On libere la mémoire, prise par nos palettes de couleurs si besoin
|
|
If (LocalPalette <> nil) Then
|
|
Begin
|
|
FreeAndNil(LocalPalette);
|
|
End;
|
|
If (FGlobalPalette <> nil) Then
|
|
Begin
|
|
FreeAndNil(FGlobalPalette);
|
|
End;
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFRenderCacheListItem ]========================================}
|
|
|
|
Constructor TGIFRenderCacheListItem.Create;
|
|
Begin
|
|
Inherited Create;
|
|
FBitmap := Graphics.TBitmap.Create;
|
|
FDelay := 0;
|
|
End;
|
|
|
|
Destructor TGIFRenderCacheListItem.Destroy;
|
|
Begin
|
|
FreeAndNil(FBitmap);
|
|
Inherited Destroy;
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFRenderCacheList ]============================================}
|
|
|
|
Function TGIFRenderCacheList.GetItems(Index : Integer): TGIFRenderCacheListItem;
|
|
Begin
|
|
Result := TGIFRenderCacheListItem(Inherited Items[Index]);
|
|
End;
|
|
|
|
Procedure TGIFRenderCacheList.SetItems(Index : Integer; AGIFRenderCache : TGIFRenderCacheListItem);
|
|
Begin
|
|
Put(Index, AGIFRenderCache);
|
|
End;
|
|
|
|
Procedure TGIFRenderCacheList.Clear;
|
|
Var
|
|
anItem: TGIFRenderCacheListItem;
|
|
i: Integer;
|
|
Begin
|
|
If Count > 0 Then
|
|
Begin
|
|
For i := Count - 1 Downto 0 do
|
|
Begin
|
|
AnItem := Items[i];
|
|
If anItem <> nil Then anItem.Free;
|
|
End;
|
|
End;
|
|
Inherited Clear;
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.AddNewCache: TGIFRenderCacheListItem;
|
|
Var
|
|
anItem: TGIFRenderCacheListItem;
|
|
Begin
|
|
anitem := TGIFRenderCacheListItem.Create;
|
|
Add(anItem);
|
|
Result := Items[Self.Count - 1];
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.Add(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
Begin
|
|
Result := Inherited Add(AGIFRenderCache);
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.Extract(Item : TGIFRenderCacheListItem): TGIFRenderCacheListItem;
|
|
Begin
|
|
Result := TGIFRenderCacheListItem(Inherited Extract(Item));
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.Remove(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
Begin
|
|
Result := Inherited Remove(AGIFRenderCache);
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.IndexOf(AGIFRenderCache : TGIFRenderCacheListItem): Integer;
|
|
Begin
|
|
Result := Inherited IndexOf(AGIFRenderCache);
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.First: TGIFRenderCacheListItem;
|
|
Begin
|
|
Result := TGIFRenderCacheListItem(Inherited First);
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.Last: TGIFRenderCacheListItem;
|
|
Begin
|
|
Result := TGIFRenderCacheListItem(Inherited Last);
|
|
End;
|
|
|
|
Procedure TGIFRenderCacheList.Insert(Index : Integer; AGIFRenderCache : TGIFRenderCacheListItem);
|
|
Begin
|
|
Inherited Insert(Index, AGIFRenderCache);
|
|
End;
|
|
|
|
Function TGIFRenderCacheList.IsIndexOk(anIndex: Integer): Boolean;
|
|
Begin
|
|
Result := True;
|
|
If (anIndex < 0) or (anIndex > Count-1) then result := False;
|
|
End;
|
|
|
|
Procedure TGIFRenderCacheList.Pack;
|
|
Var
|
|
i: Integer;
|
|
Begin
|
|
if Count>1 then
|
|
begin
|
|
I := 0;
|
|
While I<Count do
|
|
begin
|
|
if Items[I].IsCorrupted then
|
|
begin
|
|
Remove(Items[I]);
|
|
break;
|
|
End;
|
|
inc(I);
|
|
End;
|
|
if I<Count then Pack;
|
|
End;
|
|
End;
|
|
|
|
{%endregion%}
|
|
|
|
{%region=====[ TGIFViewer ]=====================================================}
|
|
|
|
Constructor TGIFViewer.Create(AOwner: TComponent);
|
|
Begin
|
|
Inherited Create(AOwner);
|
|
ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];
|
|
AutoSize := False;
|
|
FCenter := False;
|
|
FStretch := False;
|
|
FTransparent := True;
|
|
With GetControlClassDefaultSize Do SetInitialBounds(0, 0, CX, CY);
|
|
FRestoreBitmap := nil;
|
|
FRenderCache := TGIFRenderCacheList.Create(False);
|
|
FGIFLoader := TGIFImageLoader.Create;
|
|
FGIFLoader.OnLoadError := @DoInternalOnLoadError;
|
|
FVirtualView := TFastBitmap.Create;
|
|
FCurrentView := nil;
|
|
FCurrentView := Graphics.TBitmap.Create;
|
|
FRestoreBitmap := nil;
|
|
FAutoPlay := False;
|
|
FBorderShow := False;
|
|
FBorderColor := clBlack;
|
|
FBorderWidth := 1;
|
|
FBevelInner := bvNone;
|
|
FBevelOuter := bvNone;
|
|
FBevelWidth := 1;
|
|
FColor := clNone;
|
|
FDisplayInvalidFrames := False;
|
|
FAutoRemoveInvalidFrame := True;
|
|
FLastDrawMode := dmNone;
|
|
|
|
FAnimateTimer := TTimer.Create(nil);
|
|
With FAnimateTimer Do
|
|
Begin
|
|
Enabled := False;
|
|
Interval := 1000;
|
|
OnTimer := @DoTimerAnimate;
|
|
End;
|
|
FAnimateSpeed := 1;
|
|
FCurrentFrameIndex := 0;
|
|
FGIFWidth := 90;
|
|
FGIFHeight := 90;
|
|
FAutoStretchMode := smManual;
|
|
End;
|
|
|
|
Destructor TGIFViewer.Destroy;
|
|
Begin
|
|
FAnimateTimer.Enabled := False;
|
|
|
|
FreeAndNil(FAnimateTimer);
|
|
If FCurrentView <> nil Then FreeAndNil(FCurrentView);
|
|
If FRestoreBitmap <> nil Then FreeAndNil(FRestoreBitmap);
|
|
FreeAndNil(FVirtualView);
|
|
FRenderCache.Clear;
|
|
FreeAndNil(FRenderCache);
|
|
FreeAndNil(FGIFLoader);
|
|
|
|
Inherited Destroy;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetCenter(Const Value: Boolean);
|
|
Begin
|
|
If Value = FCenter Then exit;
|
|
FCenter := Value;
|
|
Invalidate;
|
|
End;
|
|
|
|
Function TGIFViewer.GetCanvas: TCanvas;
|
|
Begin
|
|
Result := Inherited Canvas;// FCurrentView.Canvas
|
|
End;
|
|
|
|
Function TGIFViewer.GetFrameCount: Integer;
|
|
Begin
|
|
If FCache Then
|
|
Result := FRenderCache.Count
|
|
Else Begin
|
|
Result := FGifLoader.FrameCount;
|
|
End;
|
|
End;
|
|
|
|
Function TGIFViewer.GetGIFVersion: String;
|
|
Begin
|
|
Result := FGIFLoader.Version;
|
|
End;
|
|
|
|
Function TGIFViewer.GetRawFrameItem(Index : Integer): TGIFImageListItem;
|
|
Begin
|
|
Result := nil;
|
|
If (Index >= 0) And (Index < FGIFLoader.FrameCount) Then Result := FGIFLoader.Frames[Index];
|
|
end;
|
|
|
|
Procedure TGIFViewer.SetAutoStretchMode(AValue: TGIFAutoStretchMode);
|
|
Begin
|
|
If FAutoStretchMode = AValue Then Exit;
|
|
FAutoStretchMode := AValue;
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetStretch(Const Value: Boolean);
|
|
Begin
|
|
If Value = FStretch Then exit;
|
|
FStretch := Value;
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetPause(Const Value: Boolean);
|
|
Begin
|
|
If Value = FPause Then exit;
|
|
FPause := Value;
|
|
If FPause Then FAnimateTimer.Enabled := False;
|
|
If Assigned(FOnPause) Then FOnPause(Self);
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetFileName(Const Value: String);
|
|
Begin
|
|
If Value = FFileName Then exit;
|
|
FFileName := Value;
|
|
LoadFromFile(FFileName);
|
|
End;
|
|
|
|
Function TGIFViewer.GetFrame(Const Index: Integer): Graphics.TBitmap;
|
|
Begin
|
|
Result := nil;
|
|
If (Index >= 0) And (Index < FrameCount) Then Result := FRenderCache.Items[Index].Bitmap;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetTransparent(Const Value: Boolean);
|
|
Begin
|
|
If FTransparent = Value Then exit;
|
|
FTransparent := Value;
|
|
FGIFLoader.Transparent := Value;
|
|
If FFileName <> '' Then LoadFromFile(FFileName);
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetBevelWidth(Const Value: TBevelWidth);
|
|
Begin
|
|
If FBevelWidth <> Value Then
|
|
Begin
|
|
FBevelWidth := Value;
|
|
Invalidate;
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFViewer.ResetCurrentView;
|
|
Var
|
|
I: Integer;
|
|
Corrupted : Boolean;
|
|
begin
|
|
if FRenderCache.Count>1 then
|
|
begin
|
|
if not(FDisplayInvalidFrames) then
|
|
begin
|
|
Corrupted := false;
|
|
i := 0;
|
|
Repeat
|
|
Corrupted := FRenderCache.Items[i].IsCorrupted;
|
|
inc(i);
|
|
until (i>FRenderCache.Count-1) or (Corrupted = false);
|
|
if (i>FRenderCache.Count-1) and (Corrupted = true) then
|
|
begin
|
|
Raise Exception.Create(rsAllFrameCorrupted);
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
Dec(i);
|
|
FCurrentframeIndex := i;
|
|
FAnimateTimer.Interval := FRenderCache.Items[i].Delay;
|
|
FCurrentView.Assign(FRenderCache.Items[i].Bitmap);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
FAnimateTimer.Interval := FRenderCache.Items[0].Delay;
|
|
FCurrentView.Assign(FRenderCache.Items[0].Bitmap);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[0].Bitmap);
|
|
end;
|
|
FLastDrawMode := dmNone;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetBevelInner(Const Value: TPanelBevel);
|
|
Begin
|
|
If BevelInner <> Value Then
|
|
Begin
|
|
FBevelInner := Value;
|
|
Invalidate;
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFViewer.SetBevelOuter(Const Value: TPanelBevel);
|
|
Begin
|
|
If BevelOuter <> Value Then
|
|
Begin
|
|
FBevelOuter := Value;
|
|
Invalidate;
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFViewer.DoInternalOnLoadError(Sender: TObject; Const ErrorCount: Integer; Const ErrorList: TStringList);
|
|
Begin
|
|
If Assigned(FOnLoadError) Then FOnloadError(Self, ErrorCount, ErrorList);
|
|
End;
|
|
|
|
Procedure TGIFViewer.DoTimerAnimate(Sender: TObject);
|
|
Begin
|
|
Inc(FCurrentFrameIndex);
|
|
If FCurrentFrameIndex > (FGIFLoader.FrameCount - 1) Then FCurrentFrameIndex := 0;
|
|
|
|
If (not FCache) and (FCurrentFrameIndex >= FRenderCache.Count) Then
|
|
Begin
|
|
RenderFrame(FCurrentFrameIndex);
|
|
End;
|
|
|
|
If Assigned(FOnFrameChange) Then FOnFrameChange(Self);
|
|
if not(FDisplayInvalidFrames) then
|
|
begin
|
|
if not(FRenderCache.Items[FCurrentFrameIndex].IsCorrupted) then
|
|
begin
|
|
FAnimateTimer.Interval := FRenderCache.Items[FCurrentFrameIndex].Delay;
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
End
|
|
else FAnimateTimer.Interval := FRenderCache.Items[FCurrentFrameIndex].Delay;
|
|
end
|
|
else
|
|
begin
|
|
FAnimateTimer.Interval := FRenderCache.Items[FCurrentFrameIndex].Delay;
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
end;
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.RenderFrame(Index: Integer);
|
|
Var
|
|
Src: TFastBitmap;
|
|
pTop, pLeft: Integer;
|
|
iDrawMode: TFastBitmapDrawMode;
|
|
TmpBmp : Graphics.TBitmap;
|
|
Begin
|
|
|
|
Src := FGIFLoader.Frames.Items[Index].Bitmap;
|
|
pLeft := FGIFLoader.Frames.Items[Index].Left;
|
|
pTop := FGIFLoader.Frames.Items[Index].Top;
|
|
|
|
FRenderCache.AddNewCache;
|
|
FRenderCache.Items[Index].Delay := FGIFLoader.Frames[Index].Delay * FAnimateSpeed;
|
|
FRenderCache.Items[Index].IsCorrupted := FGIFLoader.Frames[Index].IsCorrupted;
|
|
|
|
If (FTransparent) Then
|
|
Begin
|
|
iDrawMode := dmAlphaCheck;
|
|
End
|
|
Else
|
|
Begin
|
|
iDrawMode := dmSet;
|
|
End;
|
|
|
|
If Index = 0 Then
|
|
Begin
|
|
If (FTransparent) Then
|
|
Begin
|
|
FVirtualView.Clear(clrTransparent);
|
|
End
|
|
Else
|
|
Begin
|
|
FVirtualView.Clear(FGIFLoader.BackgroundColor);
|
|
End;
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, dmSet);
|
|
if FGIFLoader.Frames.Items[0].DrawMode = dmKeep then begin
|
|
if Assigned( FRestoreBitmap) then begin
|
|
FRestoreBitmap.Free;
|
|
end;
|
|
FRestoreBitmap := FVirtualView.Clone;
|
|
end;
|
|
End
|
|
Else
|
|
Begin
|
|
|
|
With FGIFLoader.Frames.Items[Index] Do
|
|
Begin
|
|
Case DrawMode Of
|
|
dmNone:
|
|
Begin
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, iDrawMode);
|
|
End;
|
|
dmKeep:
|
|
Begin
|
|
if FLastDrawMode = dmErase then
|
|
begin
|
|
If (FGIFLoader.Frames.Items[Index].IsTransparent And FTransparent) Then FVirtualView.Clear(clrTransparent)
|
|
Else
|
|
FVirtualView.Clear(FGIFLoader.BackgroundColor);
|
|
end;
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, iDrawMode);
|
|
If Assigned(FRestoreBitmap) Then FreeAndNil(FRestoreBitmap);
|
|
FRestoreBitmap := FVirtualView.Clone;
|
|
End;
|
|
dmErase:
|
|
Begin
|
|
If (FGIFLoader.Frames.Items[Index].IsTransparent And FTransparent) Then FVirtualView.Clear(clrTransparent)
|
|
Else
|
|
FVirtualView.Clear(FGIFLoader.BackgroundColor);
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, iDrawMode);
|
|
End;
|
|
dmRestore:
|
|
Begin
|
|
if FLastDrawMode = dmErase then
|
|
begin
|
|
If (FGIFLoader.Frames.Items[Index].IsTransparent And FTransparent) Then FVirtualView.Clear(clrTransparent)
|
|
Else
|
|
FVirtualView.Clear(FGIFLoader.BackgroundColor);
|
|
End;
|
|
|
|
If Assigned(FRestoreBitmap) Then FVirtualView.PutImage(FRestoreBitmap, 0, 0, FRestoreBitmap.Width, FRestoreBitmap.Height, 0, 0, dmSet)
|
|
else
|
|
begin
|
|
If (FGIFLoader.Frames.Items[Index].IsTransparent And FTransparent) Then FVirtualView.Clear(clrTransparent)
|
|
Else
|
|
FVirtualView.Clear(FGIFLoader.BackgroundColor);
|
|
end;
|
|
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, iDrawMode);
|
|
End;
|
|
Else
|
|
FVirtualView.PutImage(Src, 0, 0, Src.Width, Src.Height, pLeft, pTop, dmSet);
|
|
End;
|
|
FLastDrawMode := DrawMode;
|
|
End;
|
|
End;
|
|
// Note : Sous MacOS on ne peux pas assigner FRenderCache.Items[Index].Bitmap directement avec
|
|
// FVirtualView.GetBitmap; On est obligé de créer le bitmap de destination et utiliser Assign.
|
|
// Dans le cas contraire seulment la première image sera affichée.
|
|
//TmpBmp := Graphics.TBitmap.Create; <== MEMORY LEAK
|
|
TmpBmp := FVirtualView.GetBitmap;
|
|
FRenderCache.Items[Index].Bitmap.Assign(TmpBmp);
|
|
FreeAndNil(TmpBmp);
|
|
End;
|
|
|
|
Procedure TGIFViewer.ComputeCache;
|
|
Var
|
|
I: Integer;
|
|
Begin
|
|
FCurrentFrameIndex := 0;
|
|
FRenderCache.Clear;
|
|
If FGIFLoader.FrameCount > 0 Then
|
|
Begin
|
|
For I := 0 To Pred(FGIFLoader.FrameCount) Do
|
|
Begin
|
|
RenderFrame(I);
|
|
End;
|
|
end;
|
|
if AutoRemoveInvalidFrame then FRenderCache.Pack;
|
|
ResetCurrentView;
|
|
End;
|
|
|
|
Procedure TGIFViewer.CalculatePreferredSize(Var PreferredWidth, PreferredHeight: Integer; WithThemeSpace: Boolean);
|
|
Var
|
|
extraWidth: Integer;
|
|
Begin
|
|
extraWidth := - 2;
|
|
if FBorderShow then extraWidth := (FBorderWidth * 2) + (FBevelWidth * 2);
|
|
PreferredWidth := FGIFWidth + extraWidth + 2;
|
|
PreferredHeight := FGIFHeight + extraWidth + 2;
|
|
End;
|
|
|
|
Class Function TGIFViewer.GetControlClassDefaultSize: TSize;
|
|
Begin
|
|
Result.CX := 90; // = ClientWidth
|
|
Result.CY := 90; // = ClientHeight
|
|
End;
|
|
|
|
Function TGIFViewer.DestRect: TRect;
|
|
Var
|
|
PicWidth, PicHeight: Integer;
|
|
ImgWidth, ImgHeight: Integer;
|
|
n: Integer;
|
|
|
|
procedure KeepAspectRatio( Var aWidth, aHeight : Integer; MaxWidth, MaxHeight : Integer);
|
|
var
|
|
w, h : Integer;
|
|
begin
|
|
w := MaxWidth;
|
|
h := (aHeight * w) Div aWidth;
|
|
If h > MaxHeight Then
|
|
Begin
|
|
h := MaxHeight;
|
|
w := (aWidth * h) Div aHeight;
|
|
End;
|
|
aWidth := w;
|
|
aHeight := h;
|
|
End;
|
|
|
|
Begin
|
|
PicWidth := FCurrentView.Width;
|
|
PicHeight := FCurrentView.Height;
|
|
ImgWidth := ClientWidth;
|
|
ImgHeight := ClientHeight;
|
|
If (PicWidth = 0) Or (PicHeight = 0) Then Exit(Rect(0, 0, 0, 0));
|
|
|
|
if FAutoStretchMode <> smManual then
|
|
begin
|
|
Case FAutoStretchMode of
|
|
smStretchAll : FStretch := True;
|
|
smStretchOnlyBigger : if (PicWidth > ImgWidth) or (PicHeight > ImgHeight) then FStretch := True else FStretch := False;
|
|
smStretchOnlySmaller : if (PicWidth < ImgWidth) and (PicHeight < ImgHeight) then FStretch := True else FStretch := False;
|
|
end;
|
|
if Assigned(FOnStretchChanged) then FOnStretchChanged(Self,FStretch);
|
|
End;
|
|
|
|
If FStretch Then
|
|
Begin
|
|
KeepAspectRatio(PicWidth, PicHeight,ImgWidth, ImgHeight);
|
|
End;
|
|
|
|
n := FBorderWidth + FBevelWidth;
|
|
If FBorderShow Then
|
|
Begin
|
|
Result := Rect(n, n, n + PicWidth, n + PicHeight);
|
|
End
|
|
Else
|
|
Result := Rect(0, 0, PicWidth, PicHeight);
|
|
|
|
If FCenter Then
|
|
Begin
|
|
If FBorderShow Then
|
|
Begin
|
|
Result.Left := n + ((ClientWidth -(n+n)) - PicWidth) shr 1;
|
|
Result.Top := n + ((ClientHeight-(n+n)) - PicHeight) shr 1;
|
|
end
|
|
else
|
|
begin
|
|
Result.Left := ((ClientWidth - PicWidth) shr 1);
|
|
Result.Top := ((ClientHeight - PicHeight) shr 1);
|
|
end;
|
|
Result.Right := Result.Left + PicWidth;
|
|
Result.Bottom := Result.Top + PicHeight;
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFViewer.Paint;
|
|
|
|
Procedure DrawFrame;
|
|
Begin
|
|
With Inherited Canvas Do
|
|
Begin
|
|
Pen.Color := clBlack;
|
|
Pen.Style := psDash;
|
|
MoveTo(0, 0);
|
|
LineTo(Self.Width - 1, 0);
|
|
LineTo(Self.Width - 1, Self.Height - 1);
|
|
LineTo(0, Self.Height - 1);
|
|
LineTo(0, 0);
|
|
End;
|
|
End;
|
|
|
|
Var
|
|
R: TRect;
|
|
C: TCanvas;
|
|
ARect: TRect;
|
|
w: Integer;
|
|
Begin
|
|
|
|
If csDesigning In ComponentState Then DrawFrame;
|
|
|
|
C := Inherited Canvas;
|
|
FPainting := True;
|
|
R := DestRect;
|
|
Try
|
|
C.Lock;
|
|
// Fond
|
|
If (FColor <> clNone) Then //and Not(FTransparent)
|
|
Begin
|
|
With C Do
|
|
Begin
|
|
Brush.Style := bsSolid;
|
|
Brush.Color := FColor;
|
|
FillRect(0, 0, ClientWidth, ClientHeight);
|
|
End;
|
|
End;
|
|
|
|
// Bitmap
|
|
FCurrentView.Transparent := FTransparent;
|
|
C.StretchDraw(R, FCurrentView);
|
|
|
|
// Bordures
|
|
If FBorderShow Then
|
|
Begin
|
|
ARect := rect(0, 0, ClientWidth, ClientHeight);
|
|
w := FBevelWidth;
|
|
If (FBevelInner <> bvNone) And (w > 0) Then C.Frame3d(ARect, w, BevelInner); // Note: Frame3D inflates ARect
|
|
InflateRect(ARect, -(FBorderWidth + 1), -(FBorderWidth + 1));
|
|
If (FBevelOuter <> bvNone) And (w > 0) Then C.Frame3d(ARect, w, BevelOuter);
|
|
|
|
If FBorderWidth > 0 Then With C Do
|
|
Begin
|
|
Pen.Style := psSolid;
|
|
Pen.Width := FBorderWidth;
|
|
Pen.Color := FBorderColor;
|
|
Brush.Style := bsClear;
|
|
Rectangle(0, 0, ClientWidth, ClientHeight);
|
|
End;
|
|
End;
|
|
|
|
C.UnLock;
|
|
Finally
|
|
FPainting := False;
|
|
End;
|
|
|
|
Inherited Paint;
|
|
End;
|
|
|
|
Procedure TGIFViewer.Loaded;
|
|
begin
|
|
if FFileName<>'' then LoadFromFile(FFileName);
|
|
inherited Loaded;
|
|
end;
|
|
|
|
procedure TGIFViewer.BeforeLoad;
|
|
begin
|
|
FAnimateTimer.Enabled := False;
|
|
FPause := False;
|
|
FAnimated := False;
|
|
FCurrentFrameIndex := 0;
|
|
end;
|
|
|
|
procedure TGIFViewer.AfterLoad;
|
|
begin
|
|
FGIFWidth := FGIFLoader.Width;
|
|
FGIFHeight := FGIFLoader.Height;
|
|
FVirtualView.SetSize(FGIFWidth, FGIFHeight);
|
|
|
|
if FCache then
|
|
ComputeCache
|
|
else begin
|
|
FRenderCache.Clear;
|
|
FCurrentFrameIndex := 0;
|
|
RenderFrame(0);
|
|
ResetCurrentView;
|
|
end;
|
|
|
|
If AutoSize Then
|
|
Begin
|
|
InvalidatePreferredSize;
|
|
AdjustSize;
|
|
End;
|
|
Invalidate;
|
|
If FAutoPlay Then Start;
|
|
end;
|
|
|
|
Procedure TGIFViewer.Invalidate;
|
|
Begin
|
|
If FPainting Then exit;
|
|
Inherited Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.LoadFromStream(aStream : TStream);
|
|
Begin
|
|
BeforeLoad;
|
|
FGIFLoader.FErrorList.Clear;
|
|
FGIFLoader.FErrorCOunt := 0;
|
|
FGIFLoader.LoadFromStream(aStream);
|
|
AfterLoad;
|
|
End;
|
|
|
|
Procedure TGIFViewer.LoadFromFile(Const aFileName: String);
|
|
Begin
|
|
BeforeLoad;
|
|
if Not(FileExists(aFileName)) then
|
|
begin
|
|
MessageDlg(Format(rsFileNotFound,[aFileName]), mtError, [mbOK],0);
|
|
Exit;
|
|
end;
|
|
FGIFLoader.LoadFromFile(aFileName);
|
|
FFileName := aFileName;
|
|
AfterLoad;
|
|
End;
|
|
|
|
Procedure TGIFViewer.LoadFromResource(Const ResName: String);
|
|
Var
|
|
Resource: TLResource;
|
|
Begin
|
|
BeforeLoad;
|
|
Resource := LazarusResources.Find(ResName);
|
|
If Resource = nil Then Raise Exception.Create(Format(rsResourceNotFound,[ResName]))
|
|
Else If CompareText(LazarusResources.Find(ResName).ValueType, 'gif') = 0 Then
|
|
Begin
|
|
FGIFLoader.LoadFromResource(ResName);
|
|
AfterLoad;
|
|
End;
|
|
End;
|
|
|
|
Procedure TGIFViewer.Start;
|
|
Begin
|
|
If Not (FPause) Then FCurrentFrameIndex := 0;
|
|
FPause := False;
|
|
FAnimated := True;
|
|
FAnimateTimer.Enabled := True;
|
|
If Assigned(FOnStart) Then FOnStart(Self);
|
|
End;
|
|
|
|
Procedure TGIFViewer.Stop;
|
|
Begin
|
|
FAnimateTimer.Enabled := False;
|
|
FAnimated := False;
|
|
FPause := False;
|
|
If Assigned(FOnStop) Then FOnStop(Self);
|
|
FCurrentframeIndex := 0;
|
|
ResetCurrentView;
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.Pause;
|
|
Begin
|
|
FAnimateTimer.Enabled := False;
|
|
FPause := True;
|
|
End;
|
|
|
|
Procedure TGIFViewer.NextFrame;
|
|
begin
|
|
if FCurrentFrameIndex < FGifLoader.FrameCount - 1 then
|
|
begin
|
|
Inc(FCurrentFrameIndex);
|
|
|
|
repeat
|
|
|
|
If (not FCache) and (FCurrentFrameIndex >= FRenderCache.Count) Then
|
|
begin
|
|
RenderFrame(FCurrentFrameIndex);
|
|
end;
|
|
|
|
If Assigned(FOnFrameChange) Then FOnFrameChange(Self);
|
|
|
|
if not(FDisplayInvalidFrames) then
|
|
begin
|
|
if not(FRenderCache.Items[FCurrentFrameIndex].IsCorrupted) then
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
End
|
|
Else If FCurrentFrameIndex > 0 Then
|
|
Begin
|
|
Inc(FCurrentFrameIndex);
|
|
Continue;
|
|
End;
|
|
end
|
|
else
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
end;
|
|
Break;
|
|
until False;
|
|
|
|
FAnimateTimer.Interval := FRenderCache.Items[FCurrentFrameIndex].Delay;
|
|
end;
|
|
Invalidate;
|
|
end;
|
|
|
|
Procedure TGIFViewer.PriorFrame;
|
|
begin
|
|
if FCurrentFrameIndex > 0 then
|
|
begin
|
|
Dec(FCurrentFrameIndex);
|
|
|
|
repeat
|
|
If Assigned(FOnFrameChange) Then FOnFrameChange(Self);
|
|
|
|
if not(FDisplayInvalidFrames) then
|
|
begin
|
|
if not(FRenderCache.Items[FCurrentFrameIndex].IsCorrupted) then
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
End
|
|
Else If FCurrentFrameIndex > 0 Then
|
|
Begin
|
|
Dec(FCurrentFrameIndex);
|
|
Continue;
|
|
End;
|
|
end
|
|
else
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[FCurrentFrameIndex].Bitmap);
|
|
end;
|
|
Break;
|
|
until False;
|
|
|
|
FAnimateTimer.Interval := FRenderCache.Items[FCurrentFrameIndex].Delay;
|
|
end;
|
|
Invalidate;
|
|
end;
|
|
|
|
Function TGIFViewer.GetRawFrame(Index: Integer): TBitmap;
|
|
Begin
|
|
Result := FGIFLoader.Frames[Index].Bitmap.GetBitmap;
|
|
End;
|
|
|
|
Procedure TGIFViewer.DisplayFrame(Index: Integer);
|
|
Begin
|
|
If not(FRenderCache.IsIndexOk(Index)) then exit;
|
|
if Not(DisplayInvalidFrames) then
|
|
begin
|
|
if FRenderCache.Items[Index].IsCorrupted then
|
|
begin
|
|
inc(Index);
|
|
DisplayFrame(Index);
|
|
End
|
|
else
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[Index].Bitmap);
|
|
End;
|
|
end
|
|
else
|
|
begin
|
|
FCurrentView.Assign(FRenderCache.Items[Index].Bitmap);
|
|
End;
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.DisplayRawFrame(Index: Integer);
|
|
Var
|
|
Tmp: Graphics.TBitmap;
|
|
Begin
|
|
If not(FRenderCache.IsIndexOk(Index)) Then exit;
|
|
Tmp := GetRawFrame(Index);
|
|
FCurrentView.Assign(Tmp);
|
|
FreeAndNil(Tmp);
|
|
Invalidate;
|
|
End;
|
|
|
|
Procedure TGIFViewer.ExtractFrame(Index: Integer; Var bmp: TBitmap);
|
|
Begin
|
|
If not(FRenderCache.IsIndexOk(Index)) then exit;
|
|
Bmp.Assign(FRenderCache.Items[Index].Bitmap);
|
|
End;
|
|
|
|
Procedure TGIFViewer.ExtractRawFrame(Index: Integer; Var bmp: TBitmap);
|
|
Var
|
|
Tmp: Graphics.TBitmap;
|
|
Begin
|
|
If not(FRenderCache.IsIndexOk(Index)) Then exit;
|
|
Tmp := GetRawFrame(Index);
|
|
Bmp.Assign(Tmp);
|
|
FreeAndNil(Tmp);
|
|
End;
|
|
|
|
{%endregion}
|
|
|
|
Procedure Register;
|
|
Begin
|
|
RegisterComponents('Misc', [TGIFView]);
|
|
End;
|
|
|
|
End.
|