cgifparser.cls

很棒的网页音乐播放器,可以嵌入网页。界面很漂亮

    If Not (g87aStart = 0 Or gColorsUsed = 0) Then ' we have a valid gif frame
    
        ' rebuild the GIF file to include only the 1st frame read
        aPointer = gHeaderLen
        If g89aStart > 0 Then   ' gif is 89a format
            ' resize array, copy header info & gif89a info
            ReDim c_GIFbytes(0 To gHeaderLen + (g87aStop - g87aStart + 1) + 8)
            CopyMemory c_GIFbytes(0), c_GIFdata(0), gHeaderLen
            CopyMemory c_GIFbytes(gHeaderLen), c_GIFdata(g89aStart), 8
            aPointer = aPointer + 8 ' adjust pointer for gif87a info
        Else
            ' resize array and copy header info only
            ReDim c_GIFbytes(0 To gHeaderLen + (g87aStop - g87aStart + 1))
            CopyMemory c_GIFbytes(0), c_GIFdata(0), gHeaderLen
        End If
        ' now copy the gif 87a info
        CopyMemory c_GIFbytes(aPointer), c_GIFdata(g87aStart), g87aStop - g87aStart + 1
        c_GIFbytes(UBound(c_GIFbytes)) = 59 ' trailer/end of file
    
        ' fix up the left/top & width/height of overall frame
        CopyMemory c_GIFbytes(aPointer + 1), 0&, &H4 ' make frame left/top zero
        CopyMemory c_GIFbytes(6), c_GIFbytes(aPointer + 5), &H4 ' make window & frame size same
    
        If transUsed = 1 Then
            ' Fix up the color table/indexes for images with transparency
            ' Why? Instead of parsing/decompressing the GIF, we will allow an API to do it for us.
            ' But that API can re-index the GIF which means we may lose track of the transparency
            ' color/index.  This happens whenever any color in the GIF's palette is duplicated.
            ' To prevent this from occuring, we simply replace the GIF's palette with another
            ' palette of non-duplicated entries. Then use the original palette after the API is done
            If aLocalTbl = 1 Then ' local color table else global
                ' local color table starts 10 bytes after the gif87a block
                aPointer = gHeaderLen + 10  ' location of table within single frame array
                aLocalTbl = g87aStart + 10  ' location of table within souce array
                ' offset single frame array when gif89a structure is used
                If Not g89aStart = 0 Then aPointer = aPointer + 8
            Else
                aPointer = 13        ' global table location
                aLocalTbl = 13       ' same in both arrays
            End If
            For p = 1 To gColorsUsed - 1
                gLong = p * 3&
                uniquePalette(gLong) = p
                uniquePalette(gLong + 1) = p
                uniquePalette(gLong + 2) = p
            Next
            ' replace the old palette with the new one
            CopyMemory c_GIFbytes(aPointer), uniquePalette(0), gColorsUsed * 3&
            Erase uniquePalette()
        Else
            TransIndex = -1
        End If
        
        ' all done parsing the GIF file, send it to routine to convert it to a 32bpp
        ParseGIF = ConvertGIFto32bpp(TransIndex, aLocalTbl, cHost)
    
    End If
    
ExitReadRoutine:
Erase c_GIFbytes()  ' bytes no longer needed
If Err Then
    Err.Clear           ' this is a GIF format, but the format is invalid
    cHost.DestroyDIB    ' something is wrong; don't allow it to continue
    ParseGIF = True     ' to other parsers
End If
End Function

Private Sub SkipGifBlock(ByRef Ptr As Long)
    ' Routine skips a block of data within the GIF file
    Dim curByte As Byte
    curByte = c_GIFdata(Ptr)
    Do While curByte > 0
        Ptr = Ptr + curByte + 1
        curByte = c_GIFdata(Ptr)
    Loop
    Ptr = Ptr + 1
End Sub

Private Function ConvertGIFto32bpp(TransIndex As Long, tblOffset As Long, cHost As c32bppDIB) As Boolean

    Dim tPic As StdPicture, tBMP As BITMAP
    
    ' used for parsing a transparent gif
    Dim X As Long, Y As Long, m As Long, dX As Long, Index As Long
    Dim gSA As SafeArray, dSA As SafeArray
    Dim Pow2(0 To 8) As Long, dibBytes() As Byte, gifBytes() As Byte
    Dim maskShift As Long, maskAND As Long
    Dim hostDC As Long
    
    ' first: have API create a stdPicture for us
    Set tPic = iparseArrayToPicture(c_GIFbytes, 0, UBound(c_GIFbytes) + 1)
    If Not tPic Is Nothing Then
        
        ' a VB stdPicture is a DIB, therefore it has a handle to the DIB bits; get it
        GetGDIObject tPic.Handle, Len(tBMP), tBMP
        If Not tBMP.bmBits = 0 Then
        
            ' have host create application's 32bpp DIB
            cHost.InitializeDIB tBMP.bmWidth, tBMP.bmHeight
            
            ' we only need to parse the palette & indexes if transparency is used
            If TransIndex = -1 Then
                hostDC = cHost.LoadDIBinDC(True)
                tPic.Render hostDC + 0&, 0&, 0&, tBMP.bmWidth + 0&, tBMP.bmHeight + 0&, _
                    0&, tPic.Height, tPic.Width, -tPic.Height, ByVal 0&
                cHost.LoadDIBinDC False
                With dSA
                    .cbElements = 1
                    .cDims = 2
                    .pvData = cHost.BitsPointer
                    .rgSABound(0).cElements = cHost.Height
                    .rgSABound(1).cElements = cHost.scanWidth
                End With
                CopyMemory ByVal VarPtrArray(dibBytes), VarPtr(dSA), 4&
                For Y = 0 To tBMP.bmHeight - 1
                    For X = 3 To cHost.scanWidth - 1 Step 4
                        dibBytes(X, Y) = 255
                    Next
                Next
                CopyMemory ByVal VarPtrArray(dibBytes), 0&, 4&
            
            Else
                ' next: getting ready to parse the paletted stdPic
                Pow2(0) = 1
                For X = 1 To tBMP.bmBitsPixel   ' power of 2 array
                    Pow2(X) = Pow2(X - 1) * 2
                Next
                maskAND = Pow2(tBMP.bmBitsPixel) - 1 ' AND mask for stdPic indexes
                ' we need to overlay arrays onto the stdPic and the host's DIB pointers
                With gSA
                    .cbElements = 1
                    .cDims = 2
                    .pvData = tBMP.bmBits
                    .rgSABound(0).cElements = tBMP.bmHeight
                    .rgSABound(1).cElements = iparseByteAlignOnWord(tBMP.bmBitsPixel, tBMP.bmWidth)
                End With
                With dSA
                    .cbElements = 1
                    .cDims = 2
                    .pvData = cHost.BitsPointer
                    .rgSABound(0).cElements = cHost.Height
                    .rgSABound(1).cElements = cHost.scanWidth
                End With
                CopyMemory ByVal VarPtrArray(gifBytes), VarPtr(gSA), 4&
                CopyMemory ByVal VarPtrArray(dibBytes), VarPtr(dSA), 4&
                
                ' last: start parsing stdPic's paletted DIB
                For Y = 0 To tBMP.bmHeight - 1
                    dX = 0: m = 0   ' reset dX=host DIB's X & M=stdPic DIB's X
                    maskShift = 8 - tBMP.bmBitsPixel    ' 1st bit to process
                    
                    ' note: do not loop thru using gif ScanWidth. If the GIF
                    ' width is not DWORD ligned , you will overflow the target
                    ' DIB width and eventually write to uninitialized memory
                    For X = 1 To tBMP.bmWidth
                        ' get the palette index by shifting bits
                        Index = ((gifBytes(m, Y) \ Pow2(maskShift)) And maskAND)
                        
                        If Not Index = TransIndex Then  ' 100% opaque else 100% transparent
                            Index = Index * 3 + tblOffset
                            dibBytes(dX, Y) = c_GIFdata(Index + 2)  ' make BGR vs RGB
                            dibBytes(dX + 1, Y) = c_GIFdata(Index + 1)
                            dibBytes(dX + 2, Y) = c_GIFdata(Index)
                            dibBytes(dX + 3, Y) = 255
                        End If
                        
                        ' adjust for parsing/shifting the next index
                        If maskShift = 0 Then
                            maskShift = 8 - tBMP.bmBitsPixel ' start new byte
                            m = m + 1                        ' next stdPic byte
                        Else
                            maskShift = maskShift - tBMP.bmBitsPixel ' adjust
                        End If
                        dX = dX + 4                          ' next Host pixel
                    Next
                Next
                ' done, remove overlays
                CopyMemory ByVal VarPtrArray(gifBytes), 0&, 4&
                CopyMemory ByVal VarPtrArray(dibBytes), 0&, 4&
                cHost.Alpha = True
            End If
            cHost.ImageType = imgGIF
            ConvertGIFto32bpp = True
        End If
    End If

End Function