Attribute VB_Name = "modAniGif"
Option Explicit
Option Base 0

Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Enum GifType
    GIF87A = 0
    GIF89A = 1
End Enum

Private Type LogicalScreenDescriptor
    GifWidth As Long
    GifHeight As Long
    GlobalColorSize As Long
    SortFlag As Long
    ColorResolution As Long
    GlobalColorFlag As Long
    PixelRadio As Long
End Type

Private Type GraphicControl
    Disposal As Long
    Delay As Long
    TransparentColor As Long
    UserInput As Long
    TransparentFlag As Long
    BackColor As Long
End Type

Private Type ImageDescription
    FrameLeft As Long
    FrameTop As Long
    FrameWidth As Long
    FrameHeight As Long
End Type

Private Type Frame
    GCGraphicControl As GraphicControl
    IDImageDescription As ImageDescription
End Type

Dim fraFrame() As Frame

Public Function LoadGifFile(strFileName As String, aimg As Variant) As Long
    Dim GifHeader As GifType
    Dim strLogicalScreenDescription As String
    Dim LSDLogicalScreenDescription As LogicalScreenDescriptor
    'Dim GCGraficControl As GraphicControl
    'Dim IDImageDescription As ImageDescription
    Dim strGifHeader As String
    Dim strFrame As String
    Dim fNum As Integer
    Dim FileBuffer As String
    Dim PictureBuffer As String
    Dim PackedField As String
    Dim FirstFrame As Long
    Dim FrameEnds As Long
    Dim ActualFrame As Long
    Dim i As Integer
    
    'Test if the file exists
    If Dir$(strFileName) = "" Or strFileName = "" Then
       MsgBox "File " & strFileName & " not found", vbCritical
       Exit Function
    End If
   
    'Put all file info to a variable
    fNum = FreeFile
    Open strFileName For Binary Access Read As fNum
        FileBuffer = String(LOF(fNum), Chr(0))
        Get #fNum, , FileBuffer
    Close fNum
    
    'unload all pictureboxes\images
    For i = 1 To aimg.Count - 1
        Unload aimg(i)
    Next i
    
    'Gif Header
    strGifHeader = Left$(FileBuffer, 6)
    If strGifHeader = "GIF87a" Then
        GifHeader = GIF87A
    ElseIf strGifHeader = "GIF89a" Then
        GifHeader = GIF89A
    End If
    
    'Test if the Gif is animated or not
    FirstFrame = InStr(13, FileBuffer, Chr(33) & Chr(249))
    ActualFrame = FirstFrame
    'if the image isn't animated, then just draw it;)
    If InStr(FirstFrame + 2, FileBuffer, Chr(33) & Chr(249)) = 0 Then
        aimg(0).Picture = LoadPicture(strFileName)
        aimg(0).Tag = 0
        Exit Function
    End If
    
    'Logical Screen Description
    strLogicalScreenDescription = Mid$(FileBuffer, 7, 7)
    LSDLogicalScreenDescription.GifWidth = Asc(Mid(strLogicalScreenDescription, 1, 1)) + Asc(Mid(strLogicalScreenDescription, 2, 1)) * 256
    LSDLogicalScreenDescription.GifHeight = Asc(Mid(strLogicalScreenDescription, 3, 1)) + Asc(Mid(strLogicalScreenDescription, 4, 1)) * 256
    PackedField = Asc(Mid$(strLogicalScreenDescription, 5, 1))
    LSDLogicalScreenDescription.GlobalColorFlag = (PackedField And 128) / 2 ^ 7
    LSDLogicalScreenDescription.ColorResolution = (PackedField And 112) / 2 ^ 4
    LSDLogicalScreenDescription.SortFlag = (PackedField And 8) / 2 ^ 3
    ' NOTE - This value is meanless if GlobalColorFlag is 0
    LSDLogicalScreenDescription.GlobalColorSize = PackedField And 7
    LSDLogicalScreenDescription.GlobalColorSize = 3 * (2 ^ (LSDLogicalScreenDescription.GlobalColorSize + 1))
    LSDLogicalScreenDescription.PixelRadio = Asc(Mid$(strLogicalScreenDescription, 7, 1))
 
    
    'image count
    i = 0
    ReDim Preserve fraFrame(i)
    Do
        'get frame string
        If InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249)) <> 0 Then
            FrameEnds = InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249)) - 2
        Else
            FrameEnds = InStr(ActualFrame + 2, FileBuffer, Chr(59)) - 1
        End If
        strFrame = Mid$(FileBuffer, ActualFrame, Len(FileBuffer) - FirstFrame)
        
        'Get Grafic Control
        PackedField = Asc(Mid$(strFrame, 4, 1))
 
        fraFrame(i).GCGraphicControl.Disposal = (PackedField And 12) / 2 ^ 2

        ' ADDED BY JMS
        fraFrame(i).GCGraphicControl.UserInput = (PackedField And 2) / 2 ^ 1

        ' ADDED BY JMS
        fraFrame(i).GCGraphicControl.TransparentFlag = (PackedField And 1)

        fraFrame(i).GCGraphicControl.Delay = (Asc(Mid(strFrame, 5, 1)) + Asc(Mid(strFrame, 6, 1)) * 256) * 10
        
        ' NOTE This value is meaningless if TransparentFlag is 0
        fraFrame(i).GCGraphicControl.TransparentColor = Asc(Mid$(strFrame, 7, 1))
        
        'Get Image Description
        fraFrame(i).IDImageDescription.FrameLeft = Asc(Mid(strFrame, 10, 1)) + Asc(Mid(strFrame, 11, 1)) * 256
        fraFrame(i).IDImageDescription.FrameTop = Asc(Mid(strFrame, 12, 1)) + Asc(Mid(strFrame, 13, 1)) * 256
        fraFrame(i).IDImageDescription.FrameWidth = Asc(Mid(strFrame, 14, 1)) + Asc(Mid(strFrame, 15, 1)) * 256
        fraFrame(i).IDImageDescription.FrameHeight = Asc(Mid(strFrame, 16, 1)) + Asc(Mid(strFrame, 17, 1)) * 256
           
        'If the image array don't exist then create\load it
        If i > 0 Then
            Load aimg(i)
        End If
        
        'create the image temp
        fNum = FreeFile
        
        Open "temp.gif" For Binary As fNum
            'Debug.Print Mid$(FileBuffer, FirstFrame, Len(FileBuffer) - strFrame - 1) ' error '13': type mismatch
            PictureBuffer = Mid$(FileBuffer, 1, FirstFrame - 1) & Mid$(FileBuffer, ActualFrame, FrameEnds) & Chr(59)    '3B
            Put #fNum, 1, PictureBuffer
        Close fNum
        
        'Now change the backcolor
        aimg(i).BackColor = fraFrame(i).GCGraphicControl.TransparentColor
        
        'now load the image
        aimg(i).Picture = LoadPicture("temp.gif")
        
        'change the properties
        aimg(i).Tag = fraFrame(i).GCGraphicControl.Delay
        
        'test if theres another image
        If InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249)) = 0 Then
            Exit Do
        Else
            ActualFrame = InStr(ActualFrame + 2, FileBuffer, Chr(33) & Chr(249))
            i = i + 1
            If i > 0 Then ReDim Preserve fraFrame(i)
        End If
    Loop
    'now we can delete the temp file
    Kill "temp.gif"
    
    LoadGifFile = i + 1
        
    'Control the Disposal codes
    If aimg.Count > 1 Then
        Load aimg(aimg.Count)
        For i = 1 To aimg.Count - 2
            Select Case fraFrame(i).GCGraphicControl.Disposal
                Case 0    ' No Action
                    '
                Case 1    ' Leave
                    BitBlt aimg(aimg.Count - 1).hdc, 0, 0, aimg(i - 1).ScaleWidth, aimg(i - 1).ScaleHeight, aimg(i - 1).hdc, 0, 0, vbSrcCopy
                    TransparentBlt aimg(aimg.Count - 1).hdc, _
                        fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
                        aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, aimg(i).ScaleWidth, _
                        aimg(i).ScaleHeight, aimg(i).BackColor
                    aimg(i).Picture = aimg(aimg.Count - 1).Image
                    aimg(aimg.Count - 1).Cls
                Case 3
            End Select
            Debug.Print fraFrame(i).GCGraphicControl.Disposal
        Next i
        Unload aimg(aimg.Count - 1)
    End If
End Function
