Attribute VB_Name = "mdlAnimatedGifDisposed"
Option Explicit

Private MyPath As String
Private TotalFrames As Long
Private LogicalWidth As Long, LogicalHeight As Long
Private myBackColor As Long
Private sGifMagic As String, Trailer As String
Private TimeSpeed As Long 'used in UC

Private Type BITMAPFILEHEADER    '14 bytes
     bfType As Integer
     bfSize(3) As Byte 'Long
     'bfSize As Long
     bfReserved1 As Integer
     bfReserved2 As Integer
     'bfOffBits As Long
     bfOffBits(3) As Byte
 End Type
 
 Private Declare Function GetTempFileName _
   Lib "KERNEL32" Alias "GetTempFileNameA" _
   (ByVal lpszPath As String, _
   ByVal lpPrefixString As String, _
   ByVal wUnique As Long, _
   ByVal lpTempFileName As String) As Long
   
Private DisposalCode() As Byte
Private currentFrame As Long
Private LoopCount As Long

 Private Function GetUniqueFilename(Optional Path As String = "", _
 Optional Prefix As String = "", _
 Optional UseExtension As String = "") _
 As String
    ' Input strings must be NULL terminated.
 
    Dim wUnique As Long
    Dim lpTempFileName As String
    Dim lngRet As Long
    Dim fileHeader As BITMAPFILEHEADER
    wUnique = 0
    If Path = "" Then Path = CurDir
    lpTempFileName = Space(255)
    lngRet = GetTempFileName(Path, Prefix, _
                             wUnique, lpTempFileName)
  
    lpTempFileName = Left(lpTempFileName, _
                         InStr(lpTempFileName, Chr(0)) - 1)
    Call Kill(lpTempFileName)
    If Len(UseExtension) > 0 Then
        lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
    End If
    GetUniqueFilename = lpTempFileName
 End Function

Private Sub AddDirSep(strPathName As String)
    If Right$(RTrim$(strPathName), 1) <> "\" Then
    strPathName = RTrim$(strPathName) & "\"
    End If
End Sub

Public Function LoadAnimatedGif(sFile As String, aImg As Variant) As Boolean
    On Error Resume Next
    Dim i As Long
    Dim a As Integer
    Dim lngFind As Long, lngPreviousFind As Long, strTempFile As String
    Dim hFile         As Long
    Dim sFileHeader   As String, strTemp As String
    Dim sBuff         As String
    Dim sPicsBuff     As String
    Dim TimeWait      As Long
    Dim bSkipImage    As Boolean
    TotalFrames = 0
    If Dir$(sFile) = "" Or sFile = "" Then
        Exit Function
    End If
    MyPath = App.Path
    AddDirSep MyPath
    If aImg.Count > 1 Then
        For i = 1 To aImg.Count - 1
            Unload aImg(i)
        Next i
    End If
   
sGifMagic = Chr$(0) & Chr$(&H21) & Chr$(&HF9)
Trailer = Chr$(0) & Chr$(59)
   
    'load the gif into a string buffer
    hFile = FreeFile
    
    Open sFile For Binary Access Read As hFile
        sBuff = String(LOF(hFile), Chr(0))
        Get #hFile, , sBuff
    Close #hFile
        
    'find size of color table
    If Asc(Mid(sBuff, 11, 1)) And 128 Then
        lngFind = Asc(Mid(sBuff, 11, 1)) And 7
        lngFind = 3 * (2 ^ (lngFind + 1))
    End If
    lngPreviousFind = lngFind + 13
    sFileHeader = Left(sBuff, lngPreviousFind)
    
    'GIF?
    If Left$(sFileHeader, 3) <> "GIF" Then Exit Function
      
    'temporary file
    hFile = FreeFile
    strTempFile = GetUniqueFilename(MyPath, "p" & Chr(0), "GIF")
    Open strTempFile For Binary As hFile
   
    'locate start of a frame
    lngPreviousFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic)
    If lngPreviousFind = 0& Then lngPreviousFind = Len(sFileHeader)
    Do
        lngFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic)
        If lngFind = 0& Then lngFind = Len(sBuff) + 1
        sPicsBuff = Mid(sBuff, lngPreviousFind + 1, lngFind - lngPreviousFind - 1) & Trailer
        Put #hFile, 1, sFileHeader & sPicsBuff
        If TotalFrames = 0 Then
            aImg(0).Visible = False
            aImg(0).Picture = LoadPicture(strTempFile)
            If aImg(0).Picture.handle = 0 Then bSkipImage = True
        Else
            Load aImg(TotalFrames)
            aImg(TotalFrames).ZOrder
            aImg(TotalFrames).Picture = LoadPicture(strTempFile)
            If aImg(TotalFrames).Picture.handle = 0 Then
                Unload aImg(TotalFrames)
                bSkipImage = True
            Else
                bSkipImage = False
            End If
        End If
        If bSkipImage = False Then
            ReDim Preserve DisposalCode(0 To TotalFrames)
            DisposalCode(TotalFrames) = ((Asc(Mid$(sBuff, lngFind + 4, 1)) \ 4) And 3)
            'frame delay
            TimeWait = ((Asc(Mid(sPicsBuff, 5, 1))) + (Asc(Mid(sPicsBuff, 6, 1)) * 256&)) * 10&
            If TimeWait < 30 Then TimeWait = 30 'set a minimum delay time here
            If TimeWait > 65535 Then TimeWait = 65535
            aImg(TotalFrames).Tag = TimeWait
            
            'position
            If TotalFrames > 0 Then
                aImg(TotalFrames).Left = aImg(0).Left + Asc(Mid(sPicsBuff, 10, 1)) + (Asc(Mid(sPicsBuff, 11, 1)) * 256&)
                aImg(TotalFrames).Top = aImg(0).Top + Asc(Mid(sPicsBuff, 12, 1)) + (Asc(Mid(sPicsBuff, 13, 1)) * 256&)
            End If
            lngPreviousFind = lngFind
            TotalFrames = TotalFrames + 1
        End If
    Loop Until lngPreviousFind > Len(sBuff)
    
    Close #hFile
    Kill strTempFile
    
    LoopCount = 1
    If aImg(0).Picture.handle <> 0& Then
        TotalFrames = aImg.Count + 1
        If TotalFrames > 1 Then
            ' look for the loop count identified by Block Introducer 33 & Identifier of 255 followed by 11 bytes
            lngFind = InStr(Len(sFileHeader) + 1, sBuff, Chr$(33) & Chr$(255) & Chr$(11))
            If lngFind Then
                If LCase(Mid$(sBuff, lngFind + 3, 11)) = "netscape2.0" Then
                    If Asc(Mid$(sBuff, lngFind + 14)) = 3 Then
                        LoopCount = Asc(Mid$(sBuff, lngFind + 16, 1)) + (Asc(Mid$(sBuff, lngFind + 17, 1))) * 256&
                        If LoopCount = 0 Then LoopCount = 1
                    End If
                End If
            End If
        End If
        LoadAnimatedGif = True
    Else
        TotalFrames = 0
    End If
    If aImg.Count > 100 Then
        Load aImg(aImg.Count)
        For a = 1 To aImg.Count - 2
            Select Case DisposalCode(a)
                Case 1 Or 2
                    'previous frame + actual frame(transparent) = result frame
                    aImg(aImg.Count - 1).Picture = Nothing
                    aImg(aImg.Count - 1).Picture = aImg(a - 1).Image
                    TransparentBlt aImg(aImg.Count - 1).hDC, 0, 0, aImg(a).ScaleWidth, aImg(a).ScaleHeight, aImg(a).hDC, 0, 0, aImg(a).ScaleWidth, aImg(a).ScaleHeight, GetPixel(aImg(a).hDC, 0, 0)
                    aImg(a).Picture = Nothing
                    aImg(a).Picture = aImg(aImg.Count - 1).Image
            End Select
        Next a
        Unload aImg.Count
    End If
    On Error GoTo 0
End Function