cicoparser.cls

防Listview控件源码

    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)

    ' 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(32 - 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