cicoparser.cls

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

Private Sub ApplyAlphaMask(Index As Long, cHost As c32bppDIB)

    ' Purpose: Either blend or simulate transparency for icons
    ' The primary DIB for this application is 32bpp. Icons may or
    '   may not be 32bpp. When 32bpp, the icon RGB values are not
    '   pre-multiplied; so we need to pre-multiply them.  When
    '   the icon is not 32bpp, then it may have transparency,
    '   and we will modify our 32bpp image to identify which
    '   pixels are transparent and which are not.

    Dim dX As Long, x As Long, y As Long, m As Long
    Dim aDIB() As Byte
    Dim Pow2(0 To 7) As Long
    Dim maskShift As Long, maskPtr As Long
    Dim maskScanWidth As Long, maskOffset As Long
    Dim bAlpha As Boolean
    
    Dim tSA As SafeArray
    With tSA                ' overlay the 32bpp dib
        .cbElements = 1     ' as bytes
        .cDims = 2          ' as 2D array
        .pvData = cHost.BitsPointer
        .rgSABound(0).cElements = cHost.Height
        .rgSABound(1).cElements = cHost.scanWidth
    End With
    CopyMemory ByVal VarPtrArray(aDIB), VarPtr(tSA), 4& ' establish overlay
    
    ' separate routines for 32bpp images and non-32bpp images.
    ' 32bpp images have the alpha mask combined with the RGB values. The
    ' transparency mask also exists but won't be used for 32bpp images.
    
    If m_icDirE(Index).wBitCount = 32 Then      ' alphablended icon
                                                ' get location of 1st color byte
        maskPtr = ColorByteOffset(Index) + 3&   ' then move to the alpha byte
        For y = 0& To cHost.Height - 1&         ' loop thru scan lines
            For x = 0& To cHost.scanWidth - 1& Step 4&
                Select Case m_Bits(maskPtr)
                Case 0          ' 100% transparent
                    CopyMemory aDIB(x, y), 0&, 4&
                Case 255        ' 100% opaque
                    aDIB(x + 3, y) = 255
                Case Else       ' blend; calculation from MSDN
                    For dX = x To x + 2&
                        aDIB(dX, y) = ((0& + m_Bits(maskPtr)) * aDIB(dX, y)) \ &HFF
                    Next
                    aDIB(dX, y) = m_Bits(maskPtr) ' keep the alpha byte value
                End Select
                maskPtr = maskPtr + 4&  ' move mask pointer to next alpha byte
            Next
        Next
        If m_icDir.idType = 1 Then cHost.ImageType = imgIconARGB Else cHost.ImageType = imgCursorARGB
        bAlpha = True
        
    Else    ' 1,2,4,8,16,24 bpp images - not alpha blended, no alph-channel
        
        Pow2(0) = 1&     ' build a power of two lookup table to parse the 1bpp mask
        For x = 1& To UBound(Pow2)
            Pow2(x) = Pow2(x - 1&) * 2&
        Next
        maskOffset = MaskByteOffset(Index)  ' location where mask starts
        maskScanWidth = iparseByteAlignOnWord(cHost.Width, 1) ' how many mask bytes per scan line
        For y = 0& To cHost.Height - 1&     ' loop thru the scan lines
            maskPtr = y * maskScanWidth + maskOffset  ' adjust mask pointer per scan line
            maskShift = 7&                            ' bit position of mask
            dX = 3&
            ' note: do not loop thru using maskScanWidth. If the icon is a custom
            ' icon that has no DWORD aligned width, you will overflow the target
            ' DIB width and eventually write to uninitialized memory
            For x = 1& To cHost.Width
                If (m_Bits(maskPtr) And Pow2(maskShift)) = 0 Then ' is pixel transparent?
                    aDIB(dX, y) = 255        ' nope, make it 100% opaque
                Else                        ' else make it 100% transparent
                    CopyMemory aDIB(dX - 3&, y), 0&, 4&
                    bAlpha = True
                End If
                If maskShift = 0& Then   ' when we get to zero, the mask byte is read
                    maskShift = 7&       ' reset for next mask byte
                    maskPtr = maskPtr + 1& ' move to next maskb byte
                Else
                    maskShift = maskShift - 1& ' adjust mask shifter
                End If
                dX = dX + 4&             ' move the 32bpp pointer along
            Next
        Next
        If m_icDir.idType = 1 Then cHost.ImageType = imgIcon Else cHost.ImageType = imgCursor
    End If
    CopyMemory ByVal VarPtrArray(aDIB), 0&, 4&  ' remove overlay
    cHost.Alpha = bAlpha
    
End Sub

Private Function GetBestMatch(cX As Long, cY As Long, icoBitDepth As Long) As Long

    ' Purpose: Find the nearest match to the passed Size.
    
    ' Note that this routine is weighted for monitors set at 32bit.
    ' If this is not acceptable, then algorithm slightly
    '   from adding weight of:  Abs(32 - bitDepth(icEntry))
    '   to adding weight of: Abs([ScreenColorDepth] - bitDepth(icEntry))
    
    ' additionally, the weighting is customized to favor larger icons over smaller ones
    ' when stretching would be needed. The thought is that stretching down almost always
    ' produces better quality graphics than stretching up.

    Dim Weights() As Long
    Dim icEntry As Long, bestMatch As Long
    Dim lWeight As Long
    
    If m_icDir.idCount > 1 Then ' more than one icon?
    
        ReDim Weights(-1 To m_icDir.idCount)
        ' set least desirable weight: some large number
        Weights(0) = 10000&
        
        For icEntry = 1 To m_icDir.idCount
            ' simple weight; use the difference between desired size & icon size
            If Not m_icDirE(icEntry).wBitCount = 0 Then     ' if a image within icon file is faulty, we ignore it
                
                lWeight = Width(icEntry) - cX ' & penalize if stretching larger is needed
                If cX > Width(icEntry) Then lWeight = lWeight * 2&
                Weights(icEntry) = lWeight
                
                lWeight = Height(icEntry) - cY ' & penalize if stretching larger is needed
                If cY > Height(icEntry) Then lWeight = lWeight * 2&
                Weights(icEntry) = Weights(icEntry) + lWeight
                
                ' add the weight for bit depth
                Weights(icEntry) = Weights(icEntry) + Abs(icoBitDepth - bitDepth(icEntry))
                
                If m_icDirE(icEntry).wBitCount > 32 Then Weights(icEntry) = -10000&  ' if future icons are something like 48bpp
                
                ' compare; one with lowest value wins
                If Weights(icEntry) = 0 Then
                    bestMatch = icEntry
                    Exit For
                ElseIf Weights(icEntry) < Weights(0) Then
                    If Weights(icEntry) > 0 Then        ' basically rejects icons that need to be stretched up
                        Weights(0) = Weights(icEntry)
                        bestMatch = icEntry
                    End If
                End If
            End If
        Next
        If bestMatch = 0 Then ' every image is too small and must be stretched. We will get the highest negative value now
            For icEntry = icEntry - 1& To 1& Step -1&
                Weights(icEntry) = Abs(Weights(icEntry)) + Abs(32& - bitDepth(icEntry))
                If Weights(icEntry) < Weights(0) Then
                    Weights(0) = Weights(icEntry)
                    bestMatch = icEntry
                End If
                If bestMatch = 0& Then bestMatch = 1&
            Next
        End If
        
    Else ' only one icon/PNG
        If m_icDirE(1).wBitCount = 0 Then bestMatch = 0& Else bestMatch = 1&
    
    End If
    GetBestMatch = bestMatch
    
End Function

Private Function ParsePNGheader(Index As Long) As Boolean

    ' PNG's IHDR structure
    '    Width As Long              << cannot be negative
    '    Height As Long             << cannot be negative
    '    BitDepth As Byte           << must be 1,2,4,8,16
    '    ColorType As Byte          << must be 0,2,3,4,6
    '    Compression As Byte        << must be zero
    '    Filter As Byte             << must be zero
    '    Interlacing As Byte        << must be zero or one
    
    Dim lValue As Long, Offset As Long
    Const chnk_IHDR As Long = &H52444849 'Image header PNG flag
    
    On Error GoTo ExitRoutine:
    ' get the image width; the value will be a reversed long
    With m_icDirE(Index)
        
        .wPlanes = 255 ' flag for png
        
        ' verify this is a png signture
        CopyMemory lValue, m_Bits(m_icDirE(Index).dwImageOffset), 4&
        If lValue = png_Signature1 Then ' probably a png (Vista Icon)
            ' the 1st 4 bytes were verified, very next 4 bytes
            CopyMemory lValue, m_Bits(m_icDirE(Index).dwImageOffset + 4), 4&
            If lValue = png_Signature2 Then  ' definitely a png (Vista Icon)
        
            ' If this is a valid PNG, the next 4 bytes would be 13 (size of header)
            ' and the following 4 bytes would be the header name (chnk_IHDR)
            CopyMemory lValue, m_Bits(.dwImageOffset + 12&), 4&
            
                If lValue = chnk_IHDR Then
                
                    ' get PNG's width
                    CopyMemory lValue, m_Bits(.dwImageOffset + 16&), 4&
                    lValue = iparseReverseLong(lValue)
                    Select Case lValue
                        Case 256: .bWidth = 0&
                        Case 1 To 255: .bWidth = lValue
                        Case Else: .wBitCount = 0& ' prevent processing PNG as an option
                    End Select
                    
                    ' do the same for the height
                    CopyMemory lValue, m_Bits(.dwImageOffset + 20&), 4&
                    lValue = iparseReverseLong(lValue)
                    Select Case lValue
                        Case 256: .bHeight = 0&
                        Case 1 To 255: .bHeight = lValue
                        Case Else: .wBitCount = 0& ' prevent processing PNG as an option
                    End Select
                
                    If .wBitCount = 0 Then
                        .wBitCount = m_Bits(.dwImageOffset + 24&)
                        If .wBitCount = 16 Then
                            .wBitCount = 32 ' for our purposes a 48bpp image is a 32bpp image
                            
                        ElseIf Not .wBitCount = 0 Then
                            Select Case m_Bits(.dwImageOffset + 25&)
                            Case 4, 6: .wBitCount = 32  ' alpha png
                            Case 2: .wBitCount = 24     ' true color
                            Case Else                   ' no change in interpretation
                            End Select
                        End If
                    End If
                    
                    ' the remaining bytes of the IHDR are not needed for the icon class
                    ParsePNGheader = (.wBitCount > 0)
            
                End If
            End If
        End If
    End With

ExitRoutine:
If Err Then
    Err.Clear
    m_icDirE(Index).wBitCount = 0
End If
End Function