c32bppdib.cls

来自「AeroSuite--一组非常漂亮的VISTA控件集」· CLS 代码 · 共 1,364 行 · 第 1/5 页

            If Not GetIconInfo(Handle, icoInfo) = 0 Then
                ' got it; clean up the bitmap(s) created by GetIconInfo API
                If Not icoInfo.hbmColor = 0& Then DeleteObject icoInfo.hbmColor
                If Not icoInfo.hbmMask = 0& Then DeleteObject icoInfo.hbmMask
                Dim cICO As New cICOparser
                ' process icons by handle
                LoadPicture_ByHandle = cICO.ConvertstdPicTo32bpp(Handle, Me)
            End If
        End Select
    End If
    
End Function

Public Function LoadPicture_ClipBoard() As Boolean
    
    ' PURPOSE: Convert clipboard object into a 32bpp image

    On Error Resume Next
    With Clipboard
        If (.GetFormat(vbCFBitmap) Or .GetFormat(vbCFDIB) Or .GetFormat(vbCFEMetafile) Or .GetFormat(vbCFMetafile)) Then
            If Not Err Then LoadPicture_ClipBoard = LoadPicture_StdPicture(.GetData())
        End If
    End With
    If Err Then Err.Clear
End Function

Public Function LoadPicture_FromOrignalFormat(Optional ByVal iconCx As Long, _
                            Optional ByVal iconCy As Long, _
                            Optional ByVal iconBitDepth As Long) As Boolean

    ' PURPOSE: Reload the current image from the cached bytes (if any)
    ' If the original bytes were not cached when the image was loaded, then no action
    ' will be taken.  See LoadPicture_File & LoadPicture_Stream
    
    ' iconCx :: desired width of icon if file is an icon file. Default is 32x32
    ' iconCy :: desired height of icon if file is an icon file. Default is 32x32
    ' iconBitDepth :: the desired bit depth of an icon if the resource is an icon
    
    Dim tBytes() As Byte
    tBytes() = m_ImageByteCache() ' copy bytes; original are destroyed when DIB is recreated
    LoadPicture_FromOrignalFormat = Me.LoadPicture_Stream(tBytes, iconCx, iconCy, , , True, iconBitDepth)
    
End Function

Public Function GetPixel(ByVal X As Long, ByVal Y As Long, Optional ByRef AlphaValue As Long, _
                            Optional ByRef asPreMultiplied As Boolean) As Long

    ' Function will return the pixel color value and alpha value from the DIB
    ' Note that the DIB is always referenced top down within this function
    
    ' X is the left coordinate of the pixel to be returned, image always starts at 0,0
    ' Y is the top coordinate of the pixel to be returned, image always starts at 0,0
    ' AlphaValue will contain the alpha value of the pixel.
    ' asPreMultiplied. If false, then premultiplication is removed else it isn't
    
    ' Return value is the RGB color value of the pixel.
    ' If return value is -1 then the X,Y coordinates passed are invalid
    
    ' It is far more efficient to use GetDIBits or overlaying your own array when more than
    ' one pixel is required to be returned; in other words, recommend not using this
    ' function within a loop
    
    AlphaValue = 0&
    If X < 0& Or X > m_Width - 1& Then
        GetPixel = -1&
    ElseIf Y < 0& Or Y > m_Height - 1& Then
        GetPixel = -1&
    Else
        Dim pOffset As Long, pColor As Long
        ' calculate the location of the X,Y coordinate in relation to a bottom-up DIB
        pOffset = iparseSafeOffset(m_Pointer, X * 4& + ((m_Height - Y - 1&) * m_Width * 4&))
        
        ' get the alpha value
        CopyMemory AlphaValue, ByVal iparseSafeOffset(pOffset, 3&), 1&
        
        ' get the pixel color & convert it to RGB
        CopyMemory pColor, ByVal pOffset, 3&
        If asPreMultiplied = True Or (AlphaValue Mod 255) = 0 Then
            GetPixel = ((pColor And &HFF) * &H10000) Or ((pColor \ &H100) And &HFF) * &H100 Or ((pColor \ &H10000) And &HFF)
        Else    ' remove premultiplication
            pOffset = ((255& * (pColor And &HFF)) \ AlphaValue) * &H10000
            pOffset = pOffset Or ((255& * ((pColor \ &H100) And &HFF)) \ AlphaValue) * &H100
            GetPixel = pOffset Or ((255& * ((pColor \ &H10000) And &HFF)) \ AlphaValue)
        End If
    End If

End Function

Public Function GetDIBbits(outStream() As Byte, _
                Optional ByVal as2dArray As Boolean = True, _
                Optional ByVal asBGRformat As Boolean = True, _
                Optional ByVal as32bpp As Boolean = True, _
                Optional ByVal asWordAligned As Boolean = True, _
                Optional ByVal asBottomUp As Boolean = True, _
                Optional ByVal X As Long, Optional ByVal Y As Long, _
                Optional ByVal Width As Long, Optional ByVal Height As Long, _
                Optional ByVal asPreMultiplied As Boolean = True) As Boolean
                
    ' Function replicates the GetDIBits API with more flexibility.
    ' Note: Unless you need a copy of the bytes for other purposes than just
    ' referencing them, it is much more efficient to overlay your own
    ' SafeArray on the Me.BitsPointer property vs copying the bytes into an array
    
    ' Function returns True if an image exists and the array was filled.
    
    ' Parameters
    ' outStream(). An array to hold the returned bytes. Array is always zero-bound
    ' as2dArray. If True, array is returned as (0 to Columns*4-1, 0 to Rows-1) else (0 to Columns*Rows*4-1)
    ' asBGRformat. If True, pixels are in BGRalpha format else RGBalpha format
    '              The alpha byte may be excluded depending on as32bpp parameter
    ' as32bpp. If true, pixels use 4 bytes else pixels use 3 bytes (24bpp)
    ' asWordAligned. If true, scanlines/columns are word aligned else scanlines are byte aligned
    ' asBottomUp. If true, 1st row of array is bottom of picture else is top of picture
    ' X,Y. The left,top position of the image to return
    ' Width,Height. The number of columns,rows to return. Defaults are entire image
    ' asPreMultiplied. If true, returned pixels are in their default state, premultiplied
    '                  If false, premultiplication is removed.
    
    ' Tip: How to determine the scanwidth of the returned rows?
    ' 1. If as32bpp=True, then it is always Width parameter x 4
    ' 2. Otherwise, regardless of asWordAligned parameter
    '   a. If as2dArray=True, UBound(outStream,1)+1
    '   b. If as2dArray=False, (UBound(outStream)+1)\Height parameter
    
    If m_Handle = 0& Then Exit Function
    If X < 0& Or Y < 0& Then Exit Function
    
    Dim dstX As Long, dstY As Long
    Dim dstYincr As Long, bytesPP As Long
    Dim dstScanWidth As Long, srcScanWidth As Long
    
    Dim dstBytes() As Byte, srcBytes() As Byte
    Dim dstSA As SafeArray, srcSA As SafeArray
    
    Dim Rows As Long, Cols As Long, pAlpha As Byte
    
    ' validate parameters
    If Width = 0 Then Width = m_Width
    If Height = 0 Then Height = m_Height
    If Width + X > m_Width Then Width = m_Width - X
    If Height + Y > m_Height Then Height = m_Height - Y
    ' now we will set up the scanwidth and dimensioning the return array
    If as32bpp = True Then
        bytesPP = 4&
        dstScanWidth = Width * bytesPP
    Else
        bytesPP = 3&
        If asWordAligned = True Then
            dstScanWidth = iparseByteAlignOnWord(24, Width)
        Else
            dstScanWidth = Width * bytesPP
        End If
    End If
    ' size the destination array
    If as2dArray = True Then
        ReDim outStream(0 To dstScanWidth - 1&, 0 To Height - 1&)
        dstSA.pvData = VarPtr(outStream(0, 0)) ' track pointer of 1st element
    Else
        ReDim outStream(0 To dstScanWidth * Height - 1&)
        dstSA.pvData = VarPtr(outStream(0)) ' track pointer of 1st element
    End If
    
    ' quick check for copying. This is probably going to be most used
    If as32bpp = True And asBGRformat = True And asBottomUp = True Then
        If Width = m_Width And Height = m_Height And asPreMultiplied = True Then
            If as2dArray = True Then
                CopyMemory outStream(0, 0), ByVal m_Pointer, scanWidth * Height
            Else
                CopyMemory outStream(0), ByVal m_Pointer, scanWidth * Height
            End If
            GetDIBbits = True
            Exit Function
        End If
    End If
    
    ' set up overlays using identical 2D arrays
    With dstSA
        .cbElements = 1
        .cDims = 2
        .rgSABound(0).cElements = Height
        .rgSABound(1).cElements = dstScanWidth
    End With
    With srcSA
        .cbElements = 1
        .cDims = 2
        .pvData = m_Pointer
        .rgSABound(0).cElements = m_Height
        .rgSABound(1).cElements = m_Width * 4&
    End With
    CopyMemory ByVal VarPtrArray(dstBytes), VarPtr(dstSA), 4&
    CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(srcSA), 4&
    
    ' calculate destination starting row
    If asBottomUp = True Then
        dstY = Height - 1&
        dstYincr = -1&
    Else
        dstYincr = 1&
    End If
    
    srcScanWidth = (Width + X) * 4& - 1& ' position of 1st byte in DIB
    If asPreMultiplied = True Then
        For Rows = m_Height - Y - 1& To m_Height - Height - Y Step -1&
            dstX = 0&   ' destination column
            For Cols = X * 4 To srcScanWidth Step 4&
                If asBGRformat = True Then
                    CopyMemory dstBytes(dstX, dstY), srcBytes(Cols, Rows), bytesPP
                Else
                    dstBytes(dstX, dstY) = srcBytes(Cols + 2&, Rows)
                    dstBytes(dstX + 1&, dstY) = srcBytes(Cols + 1&, Rows)
                    dstBytes(dstX + 2&, dstY) = srcBytes(Cols, Rows)
                    If bytesPP = 4& Then ' want the alpha array too
                        dstBytes(dstX + 3&, dstY) = srcBytes(Cols + 3&, Rows)
                    End If
                End If
                dstX = dstX + bytesPP ' move to next destination column
            Next
            dstY = dstY + dstYincr ' next destination row
        Next
    
    Else        ' remove premultiplication
        
        For Rows = m_Height - Y - 1& To m_Height - Height - Y Step -1&
            dstX = 0&   ' destination column
            For Cols = X * 4 To srcScanWidth Step 4&
                pAlpha = srcBytes(Cols + 3&, Rows)
                If asBGRformat = True Then
                    If pAlpha = 255 Then
                        CopyMemory dstBytes(dstX, dstY), srcBytes(Cols, Rows), 3&
                    ElseIf Not pAlpha = 0 Then
                        dstBytes(dstX, dstY) = (255& * srcBytes(Cols, Rows) \ pAlpha)
                        dstBytes(dstX + 1&, dstY) = (255& * srcBytes(Cols + 1&, Rows) \ pAlpha)
                        dstBytes(dstX + 2&, dstY) = (255& * srcBytes(Cols + 2&, Rows) \ pAlpha)
                    End If
                Else        ' convert to RGB
                    If pAlpha = 255 Then
                        dstBytes(dstX, dstY) = srcBytes(Cols + 2&, Rows)
                        dstBytes(dstX + 1&, dstY) = srcBytes(Cols + 1&, Rows)
                        dstBytes(dstX + 2&, dstY) = srcBytes(Cols, Rows)
                    ElseIf Not pAlpha = 0 Then
                        dstBytes(dstX, dstY) = (255& * srcBytes(Cols + 2&, Rows) \ pAlpha)
                        dstBytes(dstX + 1&, dstY) = (255& * srcBytes(Cols + 1&, Rows) \ pAlpha)
                        dstBytes(dstX + 2&, dstY) = (255& * srcBytes(Cols, Rows) \ pAlpha)
                    End If
                End If
                If bytesPP = 4& Then dstBytes(dstX + 3&, dstY) = pAlpha   ' want the alpha array too
                dstX = dstX + bytesPP ' move to next destination column
            Next
            dstY = dstY + dstYincr ' next destination row
        Next
    End If
    ' release arrays
    CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
    CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
    GetDIBbits = True

eh:
    If Err Then
        Err.Clear
        'Stop           ' troubleshooting only
        'Resume
    End If
End Function

Public Function SetDIBbits(inStream() As Byte, _
                Optional ByVal isBGRformat As Boolean = True, _
                Optional ByVal is32bpp As Boolean = True, _
                Optional ByVal isWordAligned As Boolean = True, _
                Optional ByVal isBottomUp As Boolean = True, _
                Optional ByVal dstX As Long, Optional ByVal dstY As Long, _
                Optional ByVal dstWidth As Long, Optional ByVal dstHeight As Long) As Boolean
                
    ' Function replicates the SetDIBits API with more flexibility.