Clsgifinfo : classe pour les gif animés

Télécharger le projet
Commenter

Description

A l'origine, cette classe a été tirée depuis le site http://edais.mvps.org/ : elle permettait déjà de récupérer certaines infos sur un fichier GIF, infos globales (Hauteur, Largeur, Index de la couleur de fond dans la palette, Aspect, Taille de la palette, Palette de couleurs globale)..

Mais il n'y avait aucune info concernant les frames, j'ai donc ajouté tout ce que je pouvais à partir de la doc tirée depuis Wotsit.org : Il y a maintenant le Nombre de boucles à effectuer, le Nombre de frames, et parmis les frames: (Nombre, Position Axe X, Position Axe Y, Hauteur, Largeur, Palette de couleurs locale, Taille de la palette, Méthode de disposition, Transparence, Intervalle 1/100 sec, Index de la couleur de transparence dans la palette).

Il y a aussi quelques fonctions, comme 'FramePaletteEntryLong' pour récupérer une couleur depuis la palette...

Voilà, il y a assez d'infos comme ça pour développer un OCX de lecture de GIF animés, mais là, je laisse la place aux experts en images, et gestion de la transparence ;)

Laissez vos critiques, suggestions, améliorations ou questions....

A noter que j'avais auparavant déjà créé un OCX du genre sur ce site mais il était très mal codé !

Bonne prog ^^

PS: laissez les commentaires d'intro svp

Source / Exemple : 


'         GIF info version 1.10
'    Written by Mike D Sutton of EDais
'Completed by Grember Damien (grember.damien@free.fr)
'       Microsoft Visual Basic MVP
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 23/07/2002
' Last edited: 16/03/2006

'VERSION HISTORY:
'----------------
''Version 1.10 (03/04/2006):
'   Changed GetPalEntry() to GetPalEntryLong() to generalise the interface
'   Added Loops propertie
'   Added FrameNumber, FrameLeftPosition, FrameTopPosition, FrameWidth, FrameHeight, FrameHasLocalColourTable, FrameHasInterlace, FrameHasLocalColourTableSort, FrameLocalColourTableSize, FrameDisposalMethod, FrameHasTransparency, FrameDelayTime, FrameTransparentColorIndex,
'         FramePictureBuffer and FramePictureSave properties
'   Added FramePaletteEntryLong and FramePaletteEntryRGB functions

''Version 1.02 (29/07/2003):
'   Minor non-impact code modifications

''Version 1.01 (26/07/2002):
'   Changed GetGIFPalEntry() to GetPalEntry() to generalise the interface
'       and minor (non-impact) changes to the code.

''Version 1.0 (25/07/2002):
'   Added FileName, FileSize, Version, Width, Height, Background, Aspect,
'         BitDepth, HasGlobalColourTable and IsTerminated properties
'
'   ReadFile()              - Reads an GIF file off disk and extracts information about it
'   GetPalEntryLong()       - Returns the RGB value of an entry from the global colour palette or -1 if out of bounds
'   GetPalEntryRGB()        - Returns the R, G, B value of an entry from the global colour palette or -1 if out of bounds
'   FramePaletteEntryLong   - Returns the RGB value of an entry from the frame local colour palette or -1 if out of bounds
'   FramePaletteEntryRGB    - Returns the R, G, B value of an entry from the frame local colour palette or -1 if out of bounds
'   ClearInfo()             - Clears the public information within the class
'   SWordToUWord()          - Converts a signed Word to an unsigned DWord (Surprisingly..)
'------------------'

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type typRGBTriplet
    rgbRed As Byte
    rgbGreen As Byte
    rgbBlue As Byte
End Type

'Private Type typGIFHeaderPacked ' 1 byte
'    ghpGlobalColorTableFlag As Bit * 1
'    ghpColorResolution As Bit * 3
'    ghpSortFlag As Bit * 3             ' <= Not Used
'    ghpGlobalColorTableSize As Bit * 3
'End Type

Private Type typGIFHeader ' 13 bytes
    ghSignitare As String * 3
    ghVersion As String * 3
    ghWidth As Integer
    ghHeight As Integer
    ghPacked As Byte
    ghBackground As Byte
    ghAspect As Byte
End Type

'Private Type typGIFGraphicControlBlockPacked ' 1 byte
'    ggpReserved As Bit * 3
'    ggpDisposalMethod As Bit * 3
'    ggpUserInputFlag As Bit * 1
'    ggpTransparentColorFlag As Bit * 1
'End Type

Private Type typGIFGraphicControlBlock ' 8 bytes
    ggExtensionIntroducer As Byte
    ggControlLabel As Byte
    ggBlockSize As Byte
    ggPacked As Byte
    ggDelayTime As Integer
    ggTransparentColorIndex As Byte
    ggBlockTerminator As Byte
End Type

'Private Type typGIFImageDescriptorPacked ' 1 byte
'    gipLocalColorTableFlag As Bit * 1
'    gipInterlaceFlag As Bit * 1
'    gipSortFlag As Bit * 1
'    gipReserved As Bit * 2
'    gipLocalColorTableSize As Bit * 3
'End Type

Private Type typGIFImageDescriptor ' 10 bytes
    giSeparator As Byte
    giLeftPosition As Integer
    giTopPosition As Integer
    giWidth As Integer
    giHeight As Integer
    giPacked As Byte
End Type

Private Type typGIFImageInfo
  'ImageDescriptor
    intLeftPosition As Integer
    intTopPosition As Integer
    intWidth As Integer
    intHeight As Integer
    blnLocalColorTable As Boolean
    blnInterlace As Boolean
    blnLocalColorTableSort As Boolean
    intLocalColorTableSize As Integer
  'GraphicControlBlock
    bytDisposalMethod As Byte
    blnUserInput As Boolean
    blnTransparency As Boolean
    intDelayTime As Integer
    bytTransparentColorIndex As Byte
    PictureBuffer As String
    PictureView As StdPicture
    Palette() As typRGBTriplet
End Type

' Member variables
Dim m_FileName As String
Dim m_FileSize As Long
Dim m_Version As String * 3
Dim m_Width As Long
Dim m_Height As Long
Dim m_Background As Byte
Dim m_Aspect As Single
Dim m_BitDepth As Byte
Dim m_HasGlobalColourTable As Boolean
Dim m_IsTerminated As Boolean
Dim m_Header As String
Dim m_ImgInfo() As typGIFImageInfo
Dim m_NumFrames As Byte
Dim m_NbLoops As Integer

Dim Palette() As typRGBTriplet
Dim PalSize As Integer

Private Const GIFSig As String = "GIF"
Private Const GIFTerminator As Byte = &H3B

' Public interface to member variables
Public Property Get FileName() As String
    FileName = m_FileName
End Property

Public Property Get FileSize() As Long
    FileSize = m_FileSize
End Property

Public Property Get Version() As String
    Version = m_Version
End Property

Public Property Get Width() As Long
    Width = m_Width
End Property

Public Property Get Height() As Long
    Height = m_Height
End Property

Public Property Get Background() As Byte
    Background = m_Background
End Property

Public Property Get Aspect() As Single
    Aspect = m_Aspect
End Property

Public Property Get BitDepth() As Byte
    BitDepth = m_BitDepth
End Property

Public Property Get HasGlobalColourTable() As Boolean
    HasGlobalColourTable = m_HasGlobalColourTable
End Property

Public Property Get IsTerminated() As Boolean
    IsTerminated = m_IsTerminated
End Property

Public Property Get Loops() As Integer
    Loops = m_NbLoops
End Property

'PROPRIETES CONCERNANT LES FRAMES
Public Property Get FrameLeftPosition(ByVal index As Byte) As Integer
    FrameLeftPosition = m_ImgInfo(index).intLeftPosition
End Property

Public Property Get FrameTopPosition(ByVal index As Byte) As Integer
    FrameTopPosition = m_ImgInfo(index).intTopPosition
End Property

Public Property Get FrameWidth(ByVal index As Byte) As Integer
    FrameWidth = m_ImgInfo(index).intWidth
End Property

Public Property Get FrameHeight(ByVal index As Byte) As Integer
    FrameHeight = m_ImgInfo(index).intHeight
End Property

Public Property Get FrameHasLocalColourTable(ByVal index As Byte) As Boolean
    FrameHasLocalColourTable = m_ImgInfo(index).blnLocalColorTable
End Property

Public Property Get FrameHasInterlace(ByVal index As Byte) As Boolean
    FrameHasInterlace = m_ImgInfo(index).blnInterlace
End Property

Public Property Get FrameHasLocalColourTableSort(ByVal index As Byte) As Boolean
    FrameHasLocalColourTableSort = m_ImgInfo(index).blnLocalColorTableSort
End Property

Public Property Get FrameLocalColourTableSize(ByVal index As Byte) As Integer
    FrameLocalColourTableSize = m_ImgInfo(index).intLocalColorTableSize
End Property

Public Property Get FrameDisposalMethod(ByVal index As Byte) As Byte
    FrameDisposalMethod = m_ImgInfo(index).bytDisposalMethod
End Property

'Public Property Get FrameHasUserInput(ByVal index As Byte) As Boolean
'    FrameHasUserInput = m_ImgInfo(index).blnUserInput
'End Property

Public Property Get FrameHasTransparency(ByVal index As Byte) As Boolean
    FrameHasTransparency = m_ImgInfo(index).blnTransparency
End Property

Public Property Get FrameDelayTime(ByVal index As Byte) As Integer
    FrameDelayTime = m_ImgInfo(index).intDelayTime
End Property

Public Property Get FrameTransparentColorIndex(ByVal index As Byte) As Byte
    FrameTransparentColorIndex = m_ImgInfo(index).bytTransparentColorIndex
End Property

Public Property Get FrameNumber() As Byte
    FrameNumber = m_NumFrames
End Property

Public Property Get FramePaletteEntryLong(ByVal PicIndex As Byte, ByVal PalIndex As Byte) As String
    If (PalIndex < PalSize) And (m_ImgInfo(PicIndex).blnLocalColorTable) Then FramePaletteEntryLong = RGB( _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbRed, _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbGreen, _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbBlue) _
    Else FramePaletteEntryLong = -1
End Property

Public Property Get FramePaletteEntryRGB(ByVal PicIndex As Byte, ByVal PalIndex As Byte, ByRef bRed As Byte, ByRef bGreen As Byte, ByRef bBlue As Byte) As String
    If (PalIndex < PalSize) And (m_ImgInfo(PicIndex).blnLocalColorTable) Then
        FramePaletteEntryRGB = PalIndex
        bRed = m_ImgInfo(PicIndex).Palette(PalIndex).rgbRed
        bGreen = m_ImgInfo(PicIndex).Palette(PalIndex).rgbGreen
        bBlue = m_ImgInfo(PicIndex).Palette(PalIndex).rgbBlue
    Else
        FramePaletteEntryRGB = -1
    End If
End Property

Public Property Get FramePictureBuffer(ByVal index As Byte) As String
    FramePictureBuffer = m_Header & m_ImgInfo(index).PictureBuffer
End Property

Public Function FramePictureSave(ByVal index As Byte, ByVal sPath As String) As Boolean
  Dim FNum As Integer
  On Error GoTo Fin
    FNum = FreeFile()
    Open sPath For Binary Access Write As #FNum
        Put #FNum, , (m_Header & m_ImgInfo(index).PictureBuffer)
    Close #FNum
    FramePictureSave = True
Fin:
End Function

'Public Property Get FrameInformations(ByVal index As Byte) As typGIFImageInfo
'    FrameInformations = m_ImgInfo(index)
'End Property

' Public methods
Public Function ReadFile(ByRef inPath As String, Optional ByVal ReadFrameInfos As Boolean = True) As Boolean
    Dim FileSize As Long
    Dim FNum As Integer
    Dim TempHeader As typGIFHeader
    Dim ReadPal As Long
    Dim TempStr As String * 3
    Dim lPicOffsetStart As Long
    Dim lPicOffsetEnd As Long
    Dim TempGrphCtrl As typGIFGraphicControlBlock
    Dim TempImgDescriptor As typGIFImageDescriptor
    Dim TempByt As Byte
    Static GIFNetscape As String * 3
           GIFNetscape = Chr$(&H21) & Chr$(&HFF) & Chr$(&HB)
    Static GIFStart As String * 3
           GIFStart = Chr$(&H0) & Chr$(&H21) & Chr$(&HF9)

    Call ClearInfo

    On Error Resume Next
    If Trim$(inPath) = "" Then Exit Function
    FileSize = FileLen(inPath)
    On Error GoTo 0

    If (FileSize < 13) Then Exit Function

    FNum = FreeFile()
    Open inPath For Binary Access Read Lock Write As #FNum
        Get #FNum, , TempHeader

        ' Check signature
        If (TempHeader.ghSignitare <> GIFSig) Then
            Close #FNum
            Exit Function
        End If

        With TempHeader ' Extract information
            m_FileName = inPath
            m_FileSize = FileSize
            m_Version = .ghVersion
            m_Width = SWordToUWord(.ghWidth)
            m_Height = SWordToUWord(.ghHeight)
            m_Background = .ghBackground
            m_Aspect = IIf(.ghAspect, ((.ghAspect + &H21) / &H40), 0)
            m_BitDepth = ((.ghPacked And &H7) + 1) 'ghpGlobalColorTableSize
            m_HasGlobalColourTable = ((.ghPacked \ &H80) And &H1) = &H1 'ghpGlobalColorTableFlag
        End With

        If (m_HasGlobalColourTable) Then ' Read palette
            PalSize = 2 ^ m_BitDepth
            ReDim Palette(PalSize - 1) As typRGBTriplet
            
            For ReadPal = 0 To (PalSize - 1)
                Get #FNum, , Palette(ReadPal)
            Next ReadPal
        End If

        ''''NOMBRE DE BOUCLES
        TempStr = String(3, Chr$(0))
        Do
            Get #FNum, , TempStr
            Seek #FNum, Seek(FNum) - 2
        Loop While (TempStr <> GIFNetscape) And (Seek(FNum) < (m_FileSize - 4))
        Get #FNum, Seek(FNum) + 15, m_NbLoops
        ''''NOMBRE DE BOUCLES

    If Seek(FNum) = (m_FileSize - 4) Then GoTo Fin

'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'           PARTIE CONCERNANT LES FRAMES
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

    If Not (ReadFrameInfos) Then GoTo Fin

    ''''BUFFER DU HEADER
    m_Header = String$(Seek(FNum), Chr$(0))
    Get #FNum, 1, m_Header 'm_Header  <--   Buffer du header
    ''''BUFFER DU HEADER

  Do
 
'
' ' ' '
'' ' ' ''''''
            ''''DEBUT DE FRAME'''''''''
            TempStr = String$(3, Chr$(0))
            Seek #FNum, Seek(FNum) - 1
            Do While (TempStr <> GIFStart) And (Seek(FNum) < m_FileSize)
                Get #FNum, , TempStr
                Seek #FNum, Seek(FNum) - 2
            Loop
            lPicOffsetStart = Seek(FNum) - 1
            ''''DEBUT DE FRAME'''''''''''''''
'' ' ' ''''''
' ' ' '
'

            m_NumFrames = m_NumFrames + 1
            ReDim Preserve m_ImgInfo(m_NumFrames - 1) As typGIFImageInfo
            Get #FNum, , TempGrphCtrl
            Get #FNum, , TempImgDescriptor
            
            With m_ImgInfo(m_NumFrames - 1)
              .intLeftPosition = SWordToUWord(TempImgDescriptor.giLeftPosition)
              .intTopPosition = SWordToUWord(TempImgDescriptor.giTopPosition)
              .intWidth = SWordToUWord(TempImgDescriptor.giWidth)
              .intHeight = SWordToUWord(TempImgDescriptor.giHeight)
              .blnLocalColorTable = ((TempImgDescriptor.giPacked \ &H80) And &H1) ''
              '.blnInterlace = ((TempImgDescriptor.giPacked \ &H40) And &H1) '' (pas sûr)
              '.blnLocalColorTableSort = ((TempImgDescriptor.giPacked \ &H20) And &H1) '' (pas sûr)
               .intLocalColorTableSize = ((TempImgDescriptor.giPacked And &H7) + 1)
              .bytDisposalMethod = ((TempGrphCtrl.ggPacked And &HC))
              '.blnUserInput
              .blnTransparency = ((TempGrphCtrl.ggPacked \ &H1) And &H1) '' (pas sûr)
              .intDelayTime = SWordToUWord(TempGrphCtrl.ggDelayTime)
              .bytTransparentColorIndex = TempGrphCtrl.ggTransparentColorIndex
              'Set .PictureView = PictureFromStr(m_Header & .PictureBuffer)
             If .blnLocalColorTable Then ' Read palette
                PalSize = 2 ^ m_BitDepth
                ReDim .Palette(PalSize - 1) As typRGBTriplet
                For ReadPal = 0 To (PalSize - 1)
                    Get #FNum, , .Palette(ReadPal)
                Next ReadPal
             End If
            End With

'
' ' ' '
'' ' ' ''''''
            ''''FIN DE FRAME'''''''''''
            TempStr = String$(3, Chr$(0))
            Do
                Get #FNum, , TempStr
                Seek #FNum, Seek(FNum) - 2
            Loop While (TempStr <> GIFStart) And (Seek(FNum) < m_FileSize)
            lPicOffsetEnd = Seek(FNum) - 1
            ''''FIN DE FRAME'''''''''''''''
'' ' ' ''''''
' ' ' '
'
            ''''BUFFER DE L'IMAGE
            m_ImgInfo(m_NumFrames - 1).PictureBuffer = String$(lPicOffsetEnd - lPicOffsetStart, Chr$(0))
            Get #FNum, lPicOffsetStart + 1, m_ImgInfo(m_NumFrames - 1).PictureBuffer
            ''''BUFFER DE L'IMAGE

            If lPicOffsetEnd Then Seek #FNum, lPicOffsetEnd

  Loop While (Seek(FNum) < m_FileSize - 4)

    If m_NumFrames = 0 Then m_NumFrames = 1

Fin:
    ' Skip to the end of the file and read in last byte to check for image terminator (";")
    Get #FNum, FileSize, TempByt
    m_IsTerminated = TempByt = GIFTerminator

Close #FNum

    ' That's all there is to it!
    ReadFile = True
End Function

Public Function GetPalEntryLong(ByVal PalIndex As Byte, Optional PicIndex As Byte) As Long
    If m_ImgInfo(PicIndex).blnLocalColorTable And (PalIndex < PalSize) Then
        GetPalEntryLong = RGB( _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbRed, _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbGreen, _
        m_ImgInfo(PicIndex).Palette(PalIndex).rgbBlue)
    ElseIf (PalIndex < PalSize) And m_HasGlobalColourTable Then
        GetPalEntryLong = RGB( _
        Palette(PalIndex).rgbRed, _
        Palette(PalIndex).rgbGreen, _
        Palette(PalIndex).rgbBlue)
    Else
        GetPalEntryLong = -1
    End If
End Function

Public Function GetPalEntryRGB(ByVal PalIndex As Byte, ByRef bRed As Byte, ByRef bGreen As Byte, ByRef bBlue As Byte, Optional PicIndex As Byte) As Long
    If m_ImgInfo(PicIndex).blnLocalColorTable And (PalIndex < PalSize) Then
        GetPalEntryRGB = PalIndex
        bRed = m_ImgInfo(PicIndex).Palette(PalIndex).rgbRed
        bGreen = m_ImgInfo(PicIndex).Palette(PalIndex).rgbGreen
        bBlue = m_ImgInfo(PicIndex).Palette(PalIndex).rgbBlue
    ElseIf (PalIndex < PalSize) And m_HasGlobalColourTable Then
        GetPalEntryRGB = PalIndex
        bRed = Palette(PalIndex).rgbRed
        bGreen = Palette(PalIndex).rgbGreen
        bBlue = Palette(PalIndex).rgbBlue
    Else
        GetPalEntryRGB = -1
    End If
End Function

' Private methods
Private Sub ClearInfo()
  Dim a As Byte
    m_FileName = ""
    m_FileSize = 0
    m_Version = ""
    m_Width = 0
    m_Height = 0
    m_Background = 0
    m_Aspect = 0
    m_BitDepth = 0
    m_HasGlobalColourTable = False
    m_IsTerminated = False
    PalSize = 0
    m_NumFrames = 0
    m_Header = ""
    ReDim m_ImgInfo(0) As typGIFImageInfo
    With m_ImgInfo(0)
        .intLeftPosition = 0
        .intTopPosition = 0
        .intWidth = m_Width
        .intHeight = m_Height
        .blnLocalColorTable = False
        .blnInterlace = False
        .blnLocalColorTableSort = False
        .intLocalColorTableSize = 0
        .bytDisposalMethod = 4
        '.blnUserInput
        .blnTransparency = False
        .intDelayTime = 0
        .bytTransparentColorIndex = 0
        .PictureBuffer = ""
    End With
End Sub

Private Function SWordToUWord(ByVal inWord As Integer) As Long
    Call RtlMoveMemory(ByVal VarPtr(SWordToUWord), ByVal VarPtr(inWord), &H2)
End Function

Conclusion :


Pour initialiser les infos, appelez la fonction ReadFile(NomDeFichier)

Un grand merci à la team EDais, malgré qu'ils n'aient pas répondu à un mail de ma part... Qui a dit que je parlais mal anglais ?! ;)

VBEnJ0Y ^^
Télécharger le projet

Codes Sources

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (VBEnJ0Y)