Attribute VB_Name = "modAniGif"
'Special thanks to jmsrickland from www.VBForums.com

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
    BackgroundColor As Long
    PixelRadio As Long
End Type

Private Type GraphicControl
    Disposal As Long
    Delay As Long
    TransparentColorIndex As Long
    UserInput As Long
    TransparentFlag 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

Public Function LoadGifFile(strFileName As String, aimg As Variant) As Long
    Dim GifImageStart As String
    Dim FrameEnds As Long
    Dim GifImageString As String
    Dim fNum As Integer
    Dim FileBuffer As String
    Dim PictureBuffer As String
    Dim FirstFrame As String
    Dim PreviousFrame As String
    Dim ActualFrame As String
    Dim fraFrame() As Frame
    Dim GifHeader As GifType
    Dim strGifHeader As String
    Dim strLogicalScreenDescription As String
    Dim LSDLogicalScreenDescription As LogicalScreenDescriptor
    Dim PackedField As String
    Dim IsStatic As Long
    Dim i As Long
    
    'On Error Resume Next
    GifImageStart = Chr(33) & Chr(249) & Chr(4)
    
    'Unload all pictureboxes\images
    'and put the 1st visible
    For i = 1 To aimg.Count - 1
        Unload aimg(i)
    Next i
    aimg(0).Visible = True
    
    'Put all file info to a variable
    fNum = FreeFile
    Open strFileName For Binary Access Read As fNum
        FileBuffer = String(LOF(fNum), Chr(59))
        Get #fNum, 1, FileBuffer
    Close fNum
   
    'test if the file is a gif file
    If Left$(FileBuffer, 3) <> "GIF" Then Exit Function
    
    'Gif Header and Version
    strGifHeader = Left$(FileBuffer, 6)
    If strGifHeader = "GIF87a" Then
        GifHeader = GIF87A
    ElseIf strGifHeader = "GIF89a" Then
        GifHeader = GIF89A
    End If
    
    'see where is the 1st frame
    'it's used for create the temp file
    FirstFrame = InStr(1, FileBuffer, GifImageStart)
    
    'test if is an animation gif or not;)
    IsStatic = InStr(FirstFrame + 3, FileBuffer, GifImageStart)
    If IsStatic = 0 Then
        'if is static image then show it and then exit the function
        aimg(0).Picture = LoadPicture(strFileName)
        aimg(0).BackColor = GetPixel(aimg(0).hdc, 0, 0)
        LoadGifFile = 1
        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.BackgroundColor = Asc(Mid$(strLogicalScreenDescription, 6, 1))
    LSDLogicalScreenDescription.PixelRadio = Asc(Mid$(strLogicalScreenDescription, 7, 1))
      
       
    i = 0
    ActualFrame = 1
    ReDim Preserve fraFrame(i)
    Do
        'test where the frame starts and ends
        ActualFrame = InStr(ActualFrame + 1, FileBuffer, GifImageStart)
        FrameEnds = InStr(ActualFrame + 1, FileBuffer, GifImageStart) - 1
        If FrameEnds <= 0 Then FrameEnds = Len(FileBuffer) - 1

        'now put frame data on a variable
        GifImageString = Mid(FileBuffer, ActualFrame, FrameEnds)
        If GifImageString = "" Then Exit Do
   
        'Get Grafic Control
        PackedField = Asc(Mid$(GifImageString, 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(GifImageString, 5, 1)) + Asc(Mid(GifImageString, 6, 1)) * 256) * 10
        If fraFrame(i).GCGraphicControl.Delay = 0 Then fraFrame(i).GCGraphicControl.Delay = 250
        fraFrame(i).GCGraphicControl.TransparentColorIndex = Asc(Mid$(GifImageString, 7, 1))
        
        'Get Image Description
        fraFrame(i).IDImageDescription.FrameLeft = Asc(Mid(GifImageString, 10, 1)) + Asc(Mid(GifImageString, 11, 1)) * 256
        fraFrame(i).IDImageDescription.FrameTop = Asc(Mid(GifImageString, 12, 1)) + Asc(Mid(GifImageString, 13, 1)) * 256
        fraFrame(i).IDImageDescription.FrameWidth = Asc(Mid(GifImageString, 14, 1)) + Asc(Mid(GifImageString, 15, 1)) * 256
        fraFrame(i).IDImageDescription.FrameHeight = Asc(Mid(GifImageString, 16, 1)) + Asc(Mid(GifImageString, 17, 1)) * 256
        
        'create the image temp
        fNum = FreeFile
        
        Open App.Path & "\Temp" & i & ".gif" For Binary As fNum
            PictureBuffer = Mid$(FileBuffer, 1, FirstFrame - 1) & GifImageString & Chr(59) '3B
            Put #fNum, 1, PictureBuffer
        Close fNum
        
        'load an image\picture control if the index is more than 0(zero)
        If i > 0 Then
            Load aimg(i)
        End If
        
        PackedField = Asc(Mid(GifImageString, 18, 1))
        
        'Now change the backcolor and load the image
        aimg(i).Picture = LoadPicture(App.Path & "\Temp" & i & ".gif")
        If fraFrame(i).GCGraphicControl.TransparentFlag <> 0 Then
            aimg(i).BackColor = fraFrame(i).GCGraphicControl.TransparentFlag
        Else
            aimg(i).BackColor = GetPixel(aimg(i).hdc, 0, 0)
        End If
        If aimg(i).BackColor = 1 And fraFrame(i).GCGraphicControl.Disposal = 2 Then aimg(i).BackColor = vbWhite
        aimg(i).Picture = LoadPicture(App.Path & "\Temp" & i & ".gif")
        
        'save the Delay value
        aimg(i).Tag = fraFrame(i).GCGraphicControl.Delay
        
        'destroy the temp file
        Kill App.Path & "\Temp" & i & ".gif"
        
        'test if theres another frame
        If InStr(ActualFrame + 1, FileBuffer, GifImageStart) <= 0 Then Exit Do
        If ActualFrame = 0 Then
            If i = 0 And (aimg(i).Tag = 0 Or aimg(i).Tag = Empty) Then aimg(i).Tag = 0
            Exit Function
        End If
        Debug.Print fraFrame(i).GCGraphicControl.Disposal
        i = i + 1
        ReDim Preserve fraFrame(i)
        DoEvents
    Loop
    LoadGifFile = i + 1
    
    'Control the Disposal codes
    If aimg.Count > 1 Then
        Load aimg(aimg.Count)
        For i = 0 To aimg.Count - 2
            Select Case fraFrame(i).GCGraphicControl.Disposal
                
                Case 0, 1     ' Leave
                    If i = 0 Then
                        aimg(aimg.Count - 1).Picture = Nothing
                        aimg(aimg.Count - 1).BackColor = aimg(i).BackColor
                        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
                    Else
                        aimg(aimg.Count - 1).Picture = Nothing
                        If fraFrame(i - 1).GCGraphicControl.Disposal = 2 Or fraFrame(i - 1).GCGraphicControl.Disposal = 3 Then
                        Else
                            BitBlt aimg(aimg.Count - 1).hdc, 0, 0, aimg(i - 1).ScaleWidth, aimg(i - 1).ScaleHeight, aimg(i - 1).hdc, 0, 0, vbSrcCopy
                        End If
                        If fraFrame(i).GCGraphicControl.TransparentFlag <> 0 Then
                            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
                        Else
                            BitBlt aimg(aimg.Count - 1).hdc, fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
                                aimg(i).ScaleWidth, aimg(i).ScaleHeight, aimg(i).hdc, 0, 0, vbSrcCopy
                        End If
                        aimg(i).Picture = Nothing
                        aimg(i).Picture = aimg(aimg.Count - 1).Image
                    End If
                Case 2, 3
                    aimg(aimg.Count - 1).Picture = Nothing
                    BitBlt aimg(aimg.Count - 1).hdc, fraFrame(i).IDImageDescription.FrameLeft, fraFrame(i).IDImageDescription.FrameTop, _
                            fraFrame(i).IDImageDescription.FrameWidth, fraFrame(i).IDImageDescription.FrameHeight, aimg(i).hdc, 0, 0, vbSrcCopy
                    aimg(i).Picture = aimg(aimg.Count - 1).Image
            End Select
        Next i
        Unload aimg(aimg.Count - 1)
    End If
End Function
