VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "AnimatedGIF"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ## Created by Kristian.S.Stangeland @ 2004 ##
'
' - This code can be used in any way as long this text remains.
' If the code is compiled, please credit me somewhere in the program.
'
' ## FUNCTIONS: ##
'
' · OpenFile(PATH, HDC)
'   [in] PATH
'    Specifies the file which should be opened
'
' · DrawFrame(FrameIndex, DestHdc, x, y, Width, Height, xSrc, ySrc, dwRope)
'   [in] FrameIndex
'    What frame that should be drawed. Starts always at 0.
'
'   [in] DestHDC
'    Specifies the hdc where the frame should be drawed.
'
'   [in] x
'    Specifies the logical x-coordinate of the upper-left corner of the destination rectangle.
'
'   [in] y
'    Specifies the logical y-coordinate of the upper-left corner of the destination rectangle.
'
'   [in] Width
'    Specifies the logical width of the source and destination rectangles.
'
'   [in] Height
'    Specifies the logical height of the source and the destination rectangles.
'
'   [in] nXSrc
'     Specifies the logical x-coordinate of the upper-left corner of the source rectangle.
'
'   [in] nYSrc
'     Specifies the logical y-coordinate of the upper-left corner of the source rectangle.
'
'   [in] dwRop
'    Specifies a raster-operation code.

' - File
'    Returns the current open file
'
' - Interval(FrameIndex)
'   Returns the number of milliseconds the frame should wait.
'    [In] FrameIndex
'     What frame this should be retrived of. Starts always at 0.
'
' - CloseFile
'    Closes the current open file
'
' - TotalFrame
'    Returns the number of frames
'
' - Wait(dwMilliseconds)
'    Waits a number of milliseconds
'
' --------------- ######################### --------------------

' API CALLS:
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 Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function DeleteFile Lib "kernel32.dll" Alias "DeleteFileA" (ByVal lpFileName As String) 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 Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Type Frame
    Handle As StdPicture
    hdc As Long
    FrameWidth As Long
    FrameHeight As Long
    PosX As Long
    PosY As Long
    Redraw As Long
    TimeWait As Long
End Type

Dim lOpenFileName As String
Dim Frames() As Frame
Dim sGifMagic As String
Dim BuffFileList() As String

Dim LogicalWidth As Long
Dim LogicalHeight As Long

' The amount of frames in this GIF-file
Public TotalFrames As Long

Const MAX_PATH = 255
Const OPEN_ALWAYS As Long = 4
Const GENERIC_WRITE As Long = &H40000000
Const GENERIC_READ As Long = &H80000000
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100

Private Function CreateTempFile(strTempFile As String) As Long

    strTempFile = String(MAX_PATH, 0)
    GetTempFileName "C:\", "AniGIF", 0, strTempFile
    strTempFile = Left$(strTempFile, InStr(1, strTempFile, Chr$(0)) - 1)
    Mid(strTempFile, Len(strTempFile) - 2) = "gif"
    
    BuffFileList(UBound(BuffFileList)) = strTempFile
    ReDim Preserve BuffFileList(UBound(BuffFileList) + 1)
    
    CreateTempFile = CreateFile(strTempFile, GENERIC_WRITE Or GENERIC_READ, 0&, ByVal 0&, _
    OPEN_ALWAYS, FILE_ATTRIBUTE_TEMPORARY, 0)

End Function

Private Sub DeleteBuffFiles()
    
    Dim Tell As Long
    
    For Tell = 0 To UBound(BuffFileList) - 1
        DeleteFile BuffFileList(Tell)
    Next
    
    ReDim BuffFileList(0)

End Sub

Private Sub ToByteArray(ByteArray() As Byte, lText As String)

    Dim Tell As Long
    
    ReDim ByteArray(1 To Len(lText))
    
    For Tell = 1 To Len(lText)
        ByteArray(Tell) = Asc(Mid(lText, Tell, 1))
    Next

End Sub

Private Sub Class_Initialize()

    sGifMagic = Chr$(0) & Chr$(&H21) & Chr$(&HF9)
    
    ReDim BuffFileList(0)

End Sub

Private Sub Class_Terminate()
    
    CloseFile

End Sub

Public Property Get FrameWidth() As Long
    FrameWidth = LogicalWidth
End Property

Public Property Get FrameHeight() As Long
    FrameHeight = LogicalHeight
End Property

Public Property Get File() As String
    File = lOpenFileName
End Property

Public Property Get Interval(ByVal FrameIndex As Long) As Long
    Interval = Frames(FrameIndex).TimeWait
End Property

Public Property Get Redraw(ByVal FrameIndex As Long) As Long
    Redraw = Frames(FrameIndex).Redraw
End Property

Public Function OpenFile(sFile As String) As Long

    On Error Resume Next
    
    Dim lngFind As Long, lngPreviousFind As Long, strTempFile As String
    Dim sFileHeader As String, strTemp As String
    Dim sBuff As String, lByte() As Byte
    Dim sPicsBuff As String, hdc&
    Dim bolDoLastImage As Boolean
    Dim lngHandle As Long
    Dim hFile As Long, Ret&, Tell&
    
    ' In case someone has forgotten to close the last file
    CloseFile
    
    hdc = GetDC(GetDesktopWindow)
    hFile = FreeFile
    
    Open sFile For Binary Access Read As hFile
        sBuff = String(LOF(hFile), Chr(0))
        Get #hFile, , sBuff
    Close #hFile
            
    If Asc(Mid(sBuff, 11, 1)) And 128 Then
        lngFind = Asc(Mid(sBuff, 11, 1)) And 7
        lngFind = 3 * (2 ^ (lngFind + 1))
    End If
    
    lngFind = lngFind + 13
    sFileHeader = Left(sBuff, lngFind)
        
    If Left$(sFileHeader, 3) <> "GIF" Then
        OpenFile = 2
        Exit Function
    End If
          
    'logical dimensions
    LogicalWidth = Asc(Mid(sBuff, 7, 1)) + Asc(Mid(sBuff, 8, 1)) * 256&
    LogicalHeight = Asc(Mid(sBuff, 9, 1)) + Asc(Mid(sBuff, 10, 1)) * 256&
    
    lngHandle = CreateTempFile(strTempFile)
    lngFind = InStr(Len(sFileHeader) + 1, sBuff, sGifMagic) + 1
    
    'first image
    If lngFind > 1 Then
        sPicsBuff = sFileHeader & Mid(sBuff, Len(sFileHeader) + 1, lngFind - (Len(sFileHeader) + 1)) & Chr(59)
        ToByteArray lByte, sPicsBuff
        WriteFile lngHandle, lByte(1), UBound(lByte), Ret, ByVal 0&
        CloseHandle lngHandle
        
        ReDim Preserve Frames(TotalFrames)
        Set Frames(TotalFrames).Handle = LoadPicture(strTempFile)
        
        If Frames(TotalFrames).Handle = 0 Then TotalFrames = -1
        
        lngPreviousFind = lngFind
        lngFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic) + 1
    Else
        'only one image
        lngPreviousFind = Len(sFileHeader) + 1
        lngFind = Len(sBuff)
        bolDoLastImage = True
    End If
    
    'search next image
    Do While lngFind > 1
    
        TotalFrames = TotalFrames + 1
        ReDim Preserve Frames(TotalFrames)
        
        lngHandle = CreateTempFile(strTempFile)
        strTemp = Mid(sBuff, lngPreviousFind, lngFind - lngPreviousFind)
        sPicsBuff = sFileHeader & strTemp & Chr(59)
        
        ToByteArray lByte, sPicsBuff
        WriteFile lngHandle, lByte(1), UBound(lByte), Ret, ByVal 0&
        CloseHandle lngHandle
        
        Frames(TotalFrames).Redraw = (Asc(Mid(strTemp, 4, 1)) And 28) / 4
        Set Frames(TotalFrames).Handle = LoadPicture(strTempFile)
        
        If bolDoLastImage Then
            If Frames(TotalFrames).Handle = 0 Then
                TotalFrames = TotalFrames - 1
                ReDim Preserve Frames(TotalFrames)
                Exit Do
            End If
        End If
        
        Frames(TotalFrames).TimeWait = ((Asc(Mid(strTemp, 5, 1))) + (Asc(Mid(strTemp, 6, 1)) * 256&)) * 10&
        If Frames(TotalFrames).TimeWait < 0 Then Frames(TotalFrames).TimeWait = 0
        If Frames(TotalFrames).TimeWait > 65535 Then Frames(TotalFrames).TimeWait = 65535
        
        'position
        If TotalFrames > 1 Then
            Frames(TotalFrames).PosX = Frames(1).PosX + Asc(Mid(strTemp, 10, 1)) + (Asc(Mid(strTemp, 11, 1)) * 256&)
            Frames(TotalFrames).PosY = Frames(1).PosY + Asc(Mid(strTemp, 12, 1)) + (Asc(Mid(strTemp, 13, 1)) * 256&)
        End If
                    
        lngPreviousFind = lngFind
        lngFind = InStr(lngPreviousFind + 1, sBuff, sGifMagic) + 1
        
        'last image
        If lngFind <= 1 Then
            If Not bolDoLastImage Then
                lngFind = Len(sBuff)
                bolDoLastImage = True
            End If
        End If
    
    Loop
    
    DeleteBuffFiles
    
    For Tell = LBound(Frames) To UBound(Frames)
        Frames(Tell).FrameWidth = LogicalWidth
        Frames(Tell).FrameHeight = LogicalHeight
        Frames(Tell).hdc = CreateCompatibleDC(hdc)
        SelectObject Frames(Tell).hdc, Frames(Tell).Handle
    Next
    
    lOpenFileName = sFile
    OpenFile = 1

End Function

Public Sub CloseFile()

    On Error Resume Next
    Dim Tell&
    
    For Tell = LBound(Frames) To UBound(Frames)
        Set Frames(Tell).Handle = Nothing
        DeleteDC Frames(Tell).hdc
    Next
    
    ReDim BuffFileList(0)
    Erase Frames
    TotalFrames = 0

End Sub

Public Sub Wait(ByVal dwMilliseconds As Long)

    Dim Tell&
    
    For Tell = 1 To dwMilliseconds / 10
        Sleep 10
        DoEvents
    Next

End Sub

Public Function DrawFrame(ByVal FrameIndex As Long, ByVal DestHdc As Long, Optional x As Long, Optional y As Long, _
Optional Width As Long, Optional Height As Long, Optional xSrc As Long, Optional ySrc As Long, _
Optional dwRope As Long)
    
    If Width <= 0 Then Width = Frames(FrameIndex).FrameWidth
    If Height <= 0 Then Height = Frames(FrameIndex).FrameHeight
    If dwRope <= 0 Then dwRope = vbSrcCopy
    
    x = x + Frames(FrameIndex).PosX
    y = y + Frames(FrameIndex).PosY
    
    DrawFrame = BitBlt(DestHdc, x, y, Width, Height, Frames(FrameIndex).hdc, xSrc, ySrc, dwRope)

End Function