c32bppdib.cls

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

    ' Note: It is much more efficient to overlay your own SafeArray on
    ' the Me.BitsPointer property and updating directly
    
    ' Function returns True if an image exists and updated.
    
    ' Parameters
    ' inStream(). An array containing new DIB bytes. Can be any dimension
    ' isBGRformat. If True, pixels are in BGRalpha format else RGBalpha format
    '              The alpha byte may be excluded depending on is32bpp parameter
    ' is32bpp. If true, pixels use 4 bytes else pixels use 3 bytes (24bpp)
    ' isWordAligned. If true, scanlines are word aligned else scanlines are byte aligned
    ' isBottomUp. If true, 1st row of array is bottom of picture else is top of picture
    ' dstX,Y. The left,top position of the image to update
    ' dstWidth,Height. The number of columns,rows to update. Defaults are entire image
    
    If m_Handle = 0& Then Exit Function
    If dstX < 0& Or dstY < 0& Then Exit Function
    
    Dim SrcX As Long, SrcY As Long
    Dim srcYincr 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 srcBounds() As Long
    
    Dim Rows As Long, Cols As Long
    
    ' test and cache the passed inStream's pointer
    srcYincr = iparseIsArrayEmpty(VarPtrArray(inStream))
    If srcYincr = 0& Then Exit Function
    
    ' validate parameters
    If dstWidth = 0 Then dstWidth = m_Width
    If dstHeight = 0 Then dstHeight = m_Height
    If dstWidth + dstX > m_Width Then dstWidth = m_Width - dstX
    If dstHeight + dstY > m_Height Then dstHeight = m_Height - dstY
    
    ' now we will set up the scanwidth of the source array
    If is32bpp = True Then
        bytesPP = 4&
        srcScanWidth = dstWidth * bytesPP
    Else
        bytesPP = 3&
        If isWordAligned = True Then
            srcScanWidth = iparseByteAlignOnWord(24, dstWidth)
        Else
            srcScanWidth = dstWidth * bytesPP
        End If
    End If
    ' Get 1st 16 bytes of source SafeArray
    CopyMemory srcSA, ByVal srcYincr, 16&
    ' copy the array dimension's bounds to tempoary array
    ReDim srcBounds(1 To 2 * srcSA.cDims)
    CopyMemory srcBounds(1), ByVal srcYincr + 16&, 8& * srcSA.cDims
    ' tally up the amount of bytes contained in the array
    dstScanWidth = srcBounds(1)
    For srcSA.cDims = 3 To 2 * srcSA.cDims Step 2
        dstScanWidth = (srcBounds(srcSA.cDims) * dstScanWidth)
    Next
    ' does passed array have enough bytes?
    If dstScanWidth * srcSA.cbElements < srcScanWidth * Height Then Exit Function
    Erase srcBounds()
    
    ' set up overlay on source array
    With srcSA
        .cbElements = 1
        .cDims = 2
        .cLocks = 0     ' remove may have been set when copied
        .fFeatures = 0  ' remove may have been set when copied
        '.pvData was set when we copied the structure
        .rgSABound(0).cElements = dstHeight
        .rgSABound(1).cElements = srcScanWidth
    End With
    CopyMemory ByVal VarPtrArray(srcBytes), VarPtr(srcSA), 4&
    
    ' set up overlay on our DIB
    With dstSA
        .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&
    
    ' set source starting row
    If isBottomUp = True Then
        SrcY = dstHeight - 1
        srcYincr = -1
    Else
        srcYincr = 1
    End If
    
    dstScanWidth = (dstWidth + dstX) * 4& - 1& ' position for 1st byte in our DIB
    For Rows = m_Height - dstY - 1& To m_Height - dstHeight - dstY Step -1&
        SrcX = 0&
        For Cols = dstX * 4 To dstScanWidth Step 4&
            If isBGRformat = True Then
                CopyMemory dstBytes(Cols, Rows), srcBytes(SrcX, SrcY), bytesPP
            Else
                dstBytes(Cols, Rows) = srcBytes(SrcX + 2&, SrcY)
                dstBytes(Cols + 1&, Rows) = srcBytes(SrcX + 1&, SrcY)
                dstBytes(Cols + 2&, Rows) = srcBytes(SrcX, SrcY)
                If bytesPP = 4& Then ' want the alpha byte too
                    dstBytes(Cols + 3&, Rows) = srcBytes(SrcX + 3&, SrcY)
                End If
            End If
            SrcX = SrcX + bytesPP ' position of next source byte
        Next
        SrcY = SrcY + srcYincr  ' next source row
    Next
    ' release overlays
    CopyMemory ByVal VarPtrArray(srcBytes), 0&, 4&
    
    ' our image must remain pre-multiplied, ensure it now
    iparseValidateAlphaChannel dstBytes(), True, m_AlphaImage, 0&
    CopyMemory ByVal VarPtrArray(dstBytes), 0&, 4&
    
    SetDIBbits = True
    
End Function

Public Function CreateRegion(Optional ByVal Style As eRegionStyles = regionBounds, Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As Long
    ' Creates a region that can be used for clipping, filling, hit testing
    ' You ARE responsible for destroying the region with a call to DeleteObject
    
    ' Note: This region is created from this DIB, not the rendered DIB, therefore
    '   should the rendered DIB be of different size, mirrored, rotated or otherwise modified
    '   you should render this to a new/blank DIB and create the region from that one
    
    ' Style must be one of the following. Default is regionBounds
    '   - regionShaped: region consists of only non-transparent pixels
    '       :: example: region for the letter O would only contain the outline
    '   - regionEnclosed: transparent pixels between furthest left and furtherst right
    '       non-transparent pixels in each scan line are included in the region
    '       :: example: region for the letter O would be like filling the center then creating the region
    '   - regionBounds: all pixels within the rectangular bounds of the image are included
    '       :: example: region for the letter O would be like drawing a tight rectangle around it then creating a solid rectangular region
    ' xOffset is used to shift the region n pixels left or right
    ' yOffset is used to shift the region n pixels up or down
    
    Dim hRgn As Long
    If Not m_Handle = 0& Then
        If Style >= regionBounds And Style <= regionShaped Then
            hRgn = iparseCreateShapedRegion(Me, Style)
            If Not ((xOffset Or yOffset) = 0&) Then OffsetRgn hRgn, xOffset, yOffset
        End If
    End If
    CreateRegion = hRgn
    
End Function

Public Sub CopyImageTo(cDIBclass As c32bppDIB, Optional ByVal newWidth As Long, _
            Optional ByVal newHeight As Long, Optional ByVal CopyOriginalFormat As Boolean = False)
    
    ' Function replicates the the current image to another DIB class and optionally resizes it
    
    ' NewWidth is optional. if zero, will use the source DIB width. If negative will mirror & resize if needed
    ' NewHeight is optional. if zero, will use the source DIB height. If negative will mirror & resize if needed
    ' If CopyOriginalFormat = True then, and only, if class loaded its image
    '   with the optional SaveFormat=True, then the original image bytes
    '   were cached and will be copied to the target cDIBclass also
    '   See LoadPicture_File & LoadPicture_Stream for more info
    
    Dim dDC As Long, aResized() As Byte
    Dim bUnselect As Boolean, bResetAlphaCap As Boolean
    
    If Not m_Handle = 0& Then                ' do we have an image to copy?
    
        If newWidth = 0& Then newWidth = m_Width
        If newHeight = 0& Then newHeight = m_Height
        
        If cDIBclass Is Nothing Then
            Set cDIBclass = New c32bppDIB  ' was a valid ref passed?
            cDIBclass.gdiToken = m_GDItoken
            cDIBclass.isGDIplusEnabled = Me.isGDIplusEnabled
            cDIBclass.HighQualityInterpolation = Me.HighQualityInterpolation
            cDIBclass.InitializeDIB Abs(newWidth), Abs(newHeight) ' Create new one
        Else
            cDIBclass.gdiToken = m_GDItoken
            If Not (Abs(newWidth) = cDIBclass.Width And Abs(newHeight) = cDIBclass.Height) Then
                cDIBclass.InitializeDIB Abs(newWidth), Abs(newHeight) ' Create new one
            End If
        End If
        cDIBclass.Alpha = m_AlphaImage       ' carry over the alpha flag
        cDIBclass.ImageType = m_Format       ' and image type flag
            
        If newWidth = m_Width And newHeight = m_Height Then
            ' can copy using CopyMemory vs AlphaBlend
            CopyMemory ByVal cDIBclass.BitsPointer, ByVal m_Pointer, newWidth * 4& * newHeight
        Else
            
            If (m_osCAP And 17) = 17 Then ' system is Win98/ME with AlphaBlend capability overridden
                ' but we will be resizing DIB to DIB so disallow it for now
                m_osCAP = (m_osCAP And Not 1)
                bResetAlphaCap = True
            End If
                
            bUnselect = (m_prevObj = 0&)
            If Me.isGDIplusEnabled And (m_StretchQuality = True Or Me.isAlphaBlendFriendly = False) Then ' use GDI+ to resize
                Dim cGDIp As New cGDIPlus
                dDC = cDIBclass.LoadDIBinDC(True)
                If bUnselect Then Me.LoadDIBinDC True
                cGDIp.RenderGDIplus Me, dDC, 0&, 100&, 0&, 0&, newWidth, newHeight, 0&, 0&, m_Width, m_Height, True, gsclNone, m_GDItoken
                cDIBclass.LoadDIBinDC False
                Set cGDIp = Nothing
                If bUnselect Then Me.LoadDIBinDC False
        
            ElseIf newWidth < 0& Or newHeight < 0& Then   ' handle mirroring, AlphaBlend cannot do mirroring
                MirrorDIB 0&, 0&, 0&, 0&, newWidth, newHeight, aResized(), cDIBclass ' routine mirrors directly to DIB bytes
        
            ElseIf Me.isAlphaBlendFriendly And m_StretchQuality = False Then ' O/S has no alphablending shortfalls that are known
                dDC = cDIBclass.LoadDIBinDC(True)   ' load target into a DC
                If bUnselect Then Me.LoadDIBinDC True
                Me.Render dDC, 0&, 0&, newWidth, newHeight, 0&, 0&, m_Width, m_Height, , , False, cDIBclass
                cDIBclass.LoadDIBinDC False         ' remove DIB from DC
                If bUnselect Then Me.LoadDIBinDC False
            Else
                ' stretching is involved, resize
                Call pvResize(0&, aResized(), aResized(), cDIBclass) ' routine resizes directly to DIB bytes
            End If
            
            If bResetAlphaCap Then m_osCAP = m_osCAP Or 1
        
        End If
        ' if the original image bytes are to be copied, do them too
        If CopyOriginalFormat = True Then Call cDIBclass.SetOriginalFormat(m_ImageByteCache)
    
    End If
    
End Sub

Public Function GetOrginalFormat(outStream() As Byte) As Boolean

    ' If SaveFormat is true when LoadPicture_Stream or LoadPicture_File was
    ' called, the original bytes were cached when the image was successfully
    ' loaded. Call this to return those original bytes

    ' If there are no original bytes, the function returns False & outStream is uninitialized
    
    outStream() = m_ImageByteCache()
    GetOrginalFormat = Not (iparseIsArrayEmpty(VarPtrArray(m_ImageByteCache)) = 0&)

End Function

Friend Property Let Alpha(isAlpha As Boolean)
    m_AlphaImage = isAlpha  ' determines the flags used for AlphaBlend API
    ' this flag is set by the various image parsers; setting it yourself
    ' can produce less than desirable effects.
    ' Used in Me.Render & Me.TrimImage, cPNGwriter.OptimizeTrueColor & cPNGwriter.PalettizeImage
End Property
Public Property Get Alpha() As Boolean
    Alpha = m_AlphaImage
End Property

Public Property Let HighQualityInterpolation(Value As Boolean)
    ' When possible GDI+ will be used for stretching & rotation.
    ' If GDI+ is used,then high quality equates to BiCubic interpolation
    ' If not used, then BiLinear (manual processing) will be used.
    ' If High Quality is false, then Nearest Neighbor (very fast) interpolation used
    m_StretchQuality = Value
End Property
Public Property Get HighQualityInterpolation() As Boolean
    HighQualityInterpolation = m_StretchQuality
End Property

Public Property Get ImageType() As eImageFormat
    ImageType = m_Format    ' returns image format of the source image
End Property
Friend Property Let ImageType(iType As eImageFormat)
    m_Format = iType    ' set by the various image parsers. This is not used
    ' anywhere in these classes, you can do with it what you want -- for now.