VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cGIFParser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'****************************************************************************
'人人為我，我為人人
'枕善居收藏整理
'發(fā)布日期：2007/03/15
'描    述：網(wǎng)頁搜索音樂播放器  Ver 1.1.0
'網(wǎng)    站：http://www.Mndsoft.com/  (VB6源碼博客)
'網(wǎng)    站：http://www.VbDnet.com/   (VB.NET源碼博客,主要基于.NET2005)
'e-mail  ：Mndsoft@163.com
'e-mail  ：Mndsoft@126.com
'OICQ    ：88382850
'          如果您有新的好的代碼別忘記給枕善居哦!
'****************************************************************************
Option Explicit
' No APIs are declared public. This is to prevent possibly, differently
' declared APIs, or different versions of the same API, from conflciting
' with any APIs you declared in your project. Same rule for UDTs.

' used to extract data from a converted GIF
Private Declare Function GetGDIObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

Private Type SafeArrayBound
    cElements As Long
    lLbound As Long
End Type
Private Type SafeArray
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    rgSABound(0 To 1) As SafeArrayBound ' reusable UDT for 1 & 2 dim arrays
End Type
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private c_GIFdata() As Byte     ' source bytes (mapped array)
Private c_GIFbytes() As Byte    ' 1 frame from source bytes

Public Function LoadStream(inStream() As Byte, cHost As c32bppDIB, _
                    Optional ByVal streamOffset As Long, Optional ByVal streamLength As Long) As Boolean

    ' Parameters:
    ' insSream() :: a byte array containing a GIF
    ' cHost :: an initialized c32bppDIB
    ' streamOffset :: array position for 1st byte in the stream
    ' streamLength :: size of stream that contains the image
    '   - If zero, then size is UBound(inStream)-streamOffset+1
    
    ' IMPORTANT: the array offset & length are not checked in this class.
    '   They were checked before this class was called. If this class is to
    '   be pulled out and put in another project, ensure you include the
    '   validation shown in c32bppDIB.LoadPicture_Stream
    
    Dim tTSA As SafeArray
    ' overlay our module level array onto the passed array
    With tTSA
        .cbElements = 1         ' byte array
        .cDims = 1              ' 1 dimensional
        .pvData = VarPtr(inStream(streamOffset))
        .rgSABound(0).cElements = streamLength
    End With
    CopyMemory ByVal VarPtrArray(c_GIFdata), VarPtr(tTSA), &H4 ' apply overlay
    
    ' call routine to parse the GIF & convert it to 32bpp
    LoadStream = ParseGIF(cHost)
    CopyMemory ByVal VarPtrArray(c_GIFdata), 0&, &H4    ' remove overlay
    
End Function

Private Function ParseGIF(cHost As c32bppDIB) As Boolean

    On Error Resume Next
    ' a modified routine from some of my other GIF postings
    ' This version is scaled back and only extracts first frame
    
    ' This routine has one limitation. Some rare GIFs do not follow the
    ' standards and when those are encountered, the routine will return
    ' True to prevent it from being sent to other parsers.  This is
    ' important because the BMP parser sends the stream to an API
    ' to convert an unknown the image to a stdPicture. If the GIF stream
    ' isn't formatted within standards that API hangs the application.
    
    Dim gLong As Long
    Dim aPointer As Long
    Dim gHeaderLen As Long
    Dim g87aStart As Long, g87aStop As Long
    Dim g89aStart As Long, g89aStop As Long
    
    ' transparency flags and variables use to tweak GIF
    Dim transUsed As Byte, TransIndex As Long
    Dim aLocalTbl As Long, gColorsUsed As Long
    Dim uniquePalette(0 To 767) As Byte
    Dim p As Long
    
    On Error GoTo ExitReadRoutine
    
    ' read signature
    ReDim c_GIFbytes(0 To 5)
    CopyMemory c_GIFbytes(0), c_GIFdata(0), 6&
    Select Case LCase(StrConv(c_GIFbytes, vbUnicode))
        Case "gif89a", "gif87a"
        Case Else
            Exit Function
    End Select
        
    ' skip to the global color table information
    If (c_GIFdata(10) And 128) = 128 Then ' color table used? If so, skip it
        gColorsUsed = 2 ^ ((c_GIFdata(10) And &H7) + 1) ' count colors
        gHeaderLen = gColorsUsed * 3 + 13
    Else 'no global color table; probably uses local color tables
        gHeaderLen = 13
    End If
    aPointer = gHeaderLen
    
    Do
        Select Case c_GIFdata(aPointer)    ' read a single byte
        Case 0  ' block terminators
            aPointer = aPointer + 1
            
        Case 33 'Extension Introducer
            aPointer = aPointer + 1
            
            Select Case c_GIFdata(aPointer) ' read the extension type
            
            Case 255    ' application extension
                ' Get the length of extension: will always be 11
                aPointer = aPointer + c_GIFdata(aPointer + 1) + 2
                Call SkipGifBlock(aPointer)
                
            Case 249    ' Graphic Control Label
                        ' (description of frame & is an optional block) 8 bytes
                transUsed = (c_GIFdata(aPointer + 2) And 1)
                If transUsed = 1 Then ' has transparency?
                    TransIndex = c_GIFdata(aPointer + 5) ' cache transparency index
                End If
                g89aStart = aPointer - 1    ' location where 89a block starts
                aPointer = aPointer + 7     ' move to end of block
                
            Case Else   ' Comment block, plain text extension, or Unknown extension
                aPointer = aPointer + 1
                Call SkipGifBlock(aPointer)
            End Select
                
        Case 44 ' Image Descriptor (image dimensions & color table)
                ' mark position where image description starts
            g87aStart = aPointer
            aPointer = aPointer + 9
            ' next byte indicates if local color table used
            If (c_GIFdata(aPointer) And 128) = 128 Then   ' local color table used?
                gColorsUsed = 2 ^ ((c_GIFdata(aPointer) And &H7) + 1) ' count colors
                aPointer = aPointer + gColorsUsed * 3
                aLocalTbl = 1  ' flag indicating colors from local table vs global table
            End If
            aPointer = aPointer + 2 ' include last byte read + end of image flag
            Call SkipGifBlock(aPointer)
                
            g87aStop = aPointer - 1
            If g87aStop - g87aStart < 3 Then Exit Function ' invalid frame
            Exit Do
            
        Case Else
            ' shouldn't happen; abort with what we have
            Exit Function
        End Select
    Loop