cicoparser.cls

AeroSuite--一组非常漂亮的VISTA控件集

        End If
    End If
    
    If bIconFile Then
    
        ' Through experience, I have found the bitcount of the icons
        ' contained within the IconDirectoryEntry structures may be
        ' wrong or may not be filled in. Here, we will erase them & fill
        ' them in from the bitmap info headers that exist in the array.
        icBytesNeed = 0&
        For icEntry = 1 To m_icDir.idCount
            m_icDirE(icEntry).wPlanes = 1 ' not required, but used as a flag internally as indicating valid or invalid image
            ' get bitcount from the bitmap header
            CopyMemory icBytesNeed, m_Bits(m_icDirE(icEntry).dwImageOffset + 14), 2&
            
            If icBytesNeed = 0 Then ' if it is zero (shouldn't be); use the bitcount from the icon entry structure
                ' ensure the icon entry bitcount is not zero...
                If m_icDirE(icEntry).wBitCount = 0 Then
                    bIconFile = False
                Else
                    CopyMemory m_Bits(m_icDirE(icEntry).dwImageOffset + 14), m_icDirE(icEntry).wBitCount, 2&
                End If
                
            ElseIf icBytesNeed = 21060& Then
                ' flag for PNG, double check & abort if not -- then it is not an icon file
                bIconFile = ParsePNGheader(icEntry)
                
            Else    ' use the bitcount from the bitmap header
                m_icDirE(icEntry).wBitCount = icBytesNeed
            End If
        Next
    
        If bIconFile = True Then
            LoadStream = True

            If Not cHost Is Nothing Then
            
                ' appears we have a valid icon file. Find closest match for requested size
                If desiredWidth < 1 Then desiredWidth = 32& ' default if none provided
                If desiredHeight < 1 Then desiredHeight = 32&
                icEntry = GetBestMatch(desiredWidth, desiredHeight, icoBitDepth)
                
                If Not icEntry = 0 Then ' else something is wrong with the icon structure(s) in this file
                
                    If IsIconPNG(icEntry) Then ' png flag
                        
                        ' we need to pass this off to a PNG class for parsing/processing
                        Set cPNG = New cPNGparser
                        LoadStream = cPNG.LoadStream(inStream, cHost, m_icDirE(icEntry).dwImageOffset, m_icDirE(icEntry).dwBytesInRes, GlobalToken)
                        Set cPNG = Nothing
                        If Not cHost.Handle = 0& Then cHost.ImageType = imgPNGicon
                        
                    Else
                        ' create the main application's image, blank.
                        cHost.InitializeDIB Width(icEntry), Height(icEntry)
                        
                        ' copy the bitmap information header and fix it. Per MSDN, not all
                        ' members of the header are required to be filled in. We need them.
                        CopyMemory tBMPI.bmiHeader, m_Bits(m_icDirE(icEntry).dwImageOffset), 40&
                        With tBMPI.bmiHeader
                            .biClrUsed = ColorCount(icEntry)    ' fix when bitcount <= 8bpp
                            .biHeight = Height(icEntry)         ' height is doubled; fix it
                            .biSizeImage = 0                    ' erase; don't need this
                            .biXPelsPerMeter = 0                ' erase; don't need this
                            .biYPelsPerMeter = 0                ' erase; don't need this
                        End With
                        ' copy the fixed header back into the array
                        CopyMemory m_Bits(m_icDirE(icEntry).dwImageOffset), tBMPI.bmiHeader, 40&
                        
                        ' the next part of the routine is to create a compatible bitmap using
                        ' maximum screen colors on the system.  We will use the API to create it
                        ' for us from the bitmap header we just tweaked above. Otherwise we would
                        ' have to parse the bits ourselves, bloating code to handle 7 possible bit
                        ' depths in combination with several compression algorithms & various RGB masks.
                        tDC = GetDC(0&)
                        hDib = CreateDIBitmap(tDC, tBMPI.bmiHeader, 4, m_Bits(ColorByteOffset(icEntry)), m_Bits(m_icDirE(icEntry).dwImageOffset), 0&)
                        
                        If hDib = 0& Then
                            ReleaseDC 0&, tDC
                            cHost.DestroyDIB
                            ' major problem here; the icon contained in the stream appears to be faulty
                            ' we can't use it. Abort.
                        Else
                            ' here we are defining our application's image.
                            With tBMPI.bmiHeader
                                .biSize = 40&
                                .biBitCount = 32            ' 32bpp
                                .biHeight = cHost.Height    ' same width & height
                                .biWidth = cHost.Width      ' of the source image
                                .biPlanes = 1
                                .biSizeImage = .biHeight * .biWidth * 4&
                            End With
                            ' transfer the image bits from the bitmap created from the array to
                            ' our application's image
                            GetDIBits tDC, hDib, 0&, cHost.Height, ByVal cHost.BitsPointer, tBMPI, 0&
                            ReleaseDC 0&, tDC               ' release dc; don't need it any longer
                            DeleteObject hDib               ' kill the source bitmap; not needed
                            ApplyAlphaMask icEntry, cHost   ' add the alpha channel to app's image
                        End If
                    End If
                End If
            End If
        End If
    End If
    CopyMemory ByVal VarPtrArray(m_Bits), 0&, 4&    ' remove overlay
    
End Function

Public Function ConvertstdPicTo32bpp(Handle As Long, cHost As c32bppDIB) As Boolean

    ' Purpose: Convert a single icon from a stdPicture or handle to a 32bpp bitmap

    If Handle = 0& Then Exit Function
    
    Dim tSA As SafeArray
    Dim icoInfo As ICONINFO, tBMPI As BITMAPINFO
    Dim tBMPc As BITMAPINFO, tBMPm As BITMAPINFO
    Dim tDC As Long, hostDC As Long
    Dim x As Long, y As Long
    
    ' see if we can get the icon information
    If GetIconInfo(Handle, icoInfo) = 0& Then Exit Function
    
    m_icDir.idCount = 1
    m_icDir.idType = icoInfo.fIcon ' 0=icon, 1=cursor
    ReDim m_icDirE(1 To 1)  ' we will have 1 entry
    
    tDC = GetDC(0&)
    
    If Not icoInfo.hbmColor = 0& Then    ' do we have a color image? no for B&W
        tBMPc.bmiHeader.biSize = 40    ' let's fill in the BitmapInfo header
        If GetDIBits(tDC, icoInfo.hbmColor, 0&, 0&, ByVal 0&, tBMPc, 0&) = 0& Then
            m_icDir.idCount = 0 ' oops; something critical happened
        Else
            With tBMPI.bmiHeader    ' now fill in our destination description
                .biBitCount = 32
                .biHeight = tBMPc.bmiHeader.biHeight
                .biWidth = tBMPc.bmiHeader.biWidth
                .biPlanes = 1
                .biSize = 40&
                cHost.InitializeDIB .biWidth, .biHeight ' setup destination DIB
            End With
            ' use API again, to pass the bits from the color icon image to our DIB
            GetDIBits tDC, icoInfo.hbmColor, 0&, tBMPc.bmiHeader.biHeight, ByVal cHost.BitsPointer, tBMPI, 0&
        
            ' we will ensure the passed icon is not already a 32bpp ARGB image
            ' stdPictures won't be this way, but a call to LoadIconFromFile API can load XP icons
            With tSA
                .cbElements = 1
                .cDims = 2
                .pvData = cHost.BitsPointer
                .rgSABound(0).cElements = cHost.Height
                .rgSABound(1).cElements = cHost.scanWidth
            End With
            CopyMemory ByVal VarPtrArray(m_Bits), VarPtr(tSA), 4&
            m_icDirE(1).wBitCount = 1
            For y = 0 To cHost.Height - 1
                For x = 3 To cHost.scanWidth - 1 Step 4
                    If Not m_Bits(x, y) = 0 Then
                        m_icDirE(1).wBitCount = 32  ' looking for any non-zero alpha byte
                        y = cHost.Height            ' force outer loop to terminate
                        Exit For
                    End If
                Next
            Next
            If m_icDirE(1).wBitCount = 32 Then
                ' premultiply DIB as needed & set host imagetype, alpha properties
                iparseValidateAlphaChannel m_Bits, True, True, 0&
                If m_icDir.idType = 1 Then cHost.ImageType = imgIconARGB Else cHost.ImageType = imgCursorARGB
                cHost.Alpha = True
            End If
            CopyMemory ByVal VarPtrArray(m_Bits), 0&, 4&
        End If
    Else
        m_icDirE(1).wBitCount = 1   ' b&w icon/cursor
    End If
    
    ' pretty much same thing for the B&W, 1bpp mask
    ' Valid icons always have a mask, so no need to check .hbmMask=0 since this
    ' icon exists in a stdPicture and that, in itself, validated the icon for us
    If m_icDirE(1).wBitCount = 1 Then   ' else already processed as 32bpp icon/cursor
        If m_icDir.idCount = 1 Then
            tBMPm.bmiHeader.biSize = 40&
            If GetDIBits(tDC, icoInfo.hbmMask, 0, 0, ByVal 0&, tBMPm, 0) = 0 Then
                m_icDir.idCount = 0 ' oops; something critical happened
            Else
                With tBMPI.bmiHeader
                    If icoInfo.hbmColor = 0& Then
                        ' we have a b&w icon
                        .biBitCount = 32
                        .biHeight = tBMPm.bmiHeader.biHeight \ 2
                        .biWidth = tBMPm.bmiHeader.biWidth
                        .biPlanes = 1
                        .biSize = 40&
                        ' render the icon onto our dib
                        ' Note: in IDE, icon/cursor will be b&w, but when compiled
                        ' if the cursor had colors, the colors will be shown
                        cHost.InitializeDIB .biWidth, .biHeight  ' setup destination DIB
                        hostDC = cHost.LoadDIBinDC(True)
                        DrawIcon hostDC, 0, 0, Handle
                        cHost.LoadDIBinDC False
                        
                    End If
                    ' size our local array to hold the mask bits; these will be used
                    ' to tweak the 32bpp DIB's alpha channel in ApplyAlphaMask
                    ReDim m_Bits(0 To iparseByteAlignOnWord(1, .biWidth) * .biHeight - 1&)
                End With
                
                ' prepare bitmap info for our 1bpp mask array
                tBMPI.bmiPalette(1) = vbWhite
                With tBMPI.bmiHeader
                    .biBitCount = 1
                    .biClrUsed = 2
                End With
                ' use API again to pass the 1bpp image to our array
                GetDIBits tDC, icoInfo.hbmMask, 0&, tBMPI.bmiHeader.biHeight, m_Bits(0), tBMPI, 0&
                
                ' fill in the icon entry structure
                With m_icDirE(1)
                    .bHeight = tBMPI.bmiHeader.biHeight
                    .bWidth = tBMPm.bmiHeader.biWidth
                    .dwBytesInRes = UBound(m_Bits) + 1& ' we only have a mask in our array
                    .wBitCount = 1  ' the bitmap retrieved from the icon/cursor can be 32bpp
                    .wPlanes = 1    ' so we force the ApplyAlphaMask to use the 1bpp parsing routine
                End With
            
            End If
        End If
    End If
    ReleaseDC 0&, tDC
    
    ' clean up; GetIconInfo creates up to 2 bitmaps we must destroy
    If Not icoInfo.hbmColor = 0& Then DeleteObject icoInfo.hbmColor
    If Not icoInfo.hbmMask = 0& Then DeleteObject icoInfo.hbmMask
    
    If m_icDir.idCount = 1 Then           ' no errors encountered
        If m_icDirE(1).wBitCount = 1 Then ' now apply the mask
            ApplyAlphaMask 1&, cHost
            Erase m_Bits()
        End If
        ConvertstdPicTo32bpp = True
    End If
    
End Function