cdibsection.cls

vb 6.0 图片任意旋转问题已经解决,

                  FILE_ATTRIBUTE_NORMAL, _
                  0)
   lErr = Err.LastDllError
   If (hFile = INVALID_HANDLE_VALUE) Then
      ' error
      Err.Raise 17, App.EXEName & ".cDIBSection", ApiError(lErr)
   Else
      
      ' Writing the BITMAPFILEINFOHEADER is somewhat painful
      ' due to non-byte alignment of structure...
      hMem = GlobalAlloc(GPTR, 14)
      lPtr = GlobalLock(hMem)
      CopyMemory ByVal lPtr, tBH.bfType, 2
      CopyMemory ByVal lPtr + 2, tBH.bfSize, 4
      CopyMemory ByVal lPtr + 6, 0&, 4
      CopyMemory ByVal lPtr + 10, tBH.bfOffBits, 4
      lSize = 14
      lR = WriteFile(hFile, ByVal lPtr, lSize, lBytesWritten, ByVal 0&)
      GlobalUnlock hMem
      GlobalFree hMem
      
      ' Add the BITMAPINFOHEADER and colour palette:
      bErr = FileErrHandler(lR, lSize, lBytesWritten)
      If Not bErr Then
         lSize = Len(m_tBI)
         lR = WriteFile(hFile, m_tBI, lSize, lBytesWritten, ByVal 0&)
         bErr = FileErrHandler(lR, lSize, lBytesWritten)
      End If
      
      If Not bErr Then
         ' Its easy to write the bitmap data, though...
         lSize = m_tBI.bmiHeader.biSizeImage
         lR = WriteFile(hFile, ByVal lPtrBits, lSize, lBytesWritten, ByVal 0&)
         bErr = FileErrHandler(lR, lSize, lBytesWritten)
      End If
      
      
      CloseHandle hFile
      SaveToBitmap = Not (bErr)
   End If

End Function
Private Function ApiError(ByVal E As Long) As String
    Dim s As String, c As Long
    s = String(256, 0)
    c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                      FORMAT_MESSAGE_IGNORE_INSERTS, _
                      0, E, 0&, s, Len(s), ByVal 0)
    If c Then ApiError = Left$(s, c)
End Function
Private Function FileErrHandler( _
      ByVal lR As Long, _
      ByVal lSize As Long, ByVal lBytes As Long _
   ) As Boolean
   If (lR = 0) Or Not (lSize = lBytes) Then
      'Err.Raise
      FileErrHandler = True
   End If
End Function

Public Sub CopyToClipboard()

  Dim dsk_Wnd     As Long
  Dim dsk_hDC     As Long

  Dim clp_hDC     As Long
  Dim clp_hObj    As Long
  Dim clp_hOldObj As Long

    If (Me.hDIB <> 0) Then

        If (OpenClipboard(0) <> 0) Then

            dsk_Wnd = GetDesktopWindow
            dsk_hDC = GetDC(dsk_Wnd)

            clp_hDC = CreateCompatibleDC(dsk_hDC)
            If (clp_hDC <> 0) Then

                clp_hObj = CreateCompatibleBitmap(dsk_hDC, Me.Width, Me.Height)
                If (clp_hObj <> 0) Then

                    clp_hOldObj = SelectObject(clp_hDC, clp_hObj)
                    Me.Paint clp_hDC
                    SelectObject clp_hDC, clp_hOldObj

                    EmptyClipboard
                    SetClipboardData CF_BITMAP, clp_hObj
                    CloseClipboard

                    DeleteDC clp_hDC
                End If
            End If

            ReleaseDC dsk_Wnd, dsk_hDC
        End If
    End If
End Sub
Public Sub Paint(ByVal hDstDC As Long, Optional ByVal X As Long = 0, Optional ByVal Y As Long = 0, Optional ByVal ScaleFactor As Single = 1)
    
  Dim lret As Long
  
    If (Me.hDIB <> 0) Then
        With m_tBI.bmiHeader
            lret = StretchBlt(hDstDC, X, Y, .biWidth * ScaleFactor, -.biHeight * ScaleFactor, m_hDC, 0, 0, .biWidth, -.biHeight, SRCCOPY)
        End With
    End If
End Sub
Public Sub PaintPicture( _
        ByVal lhDC As Long, _
        Optional ByVal lDestLeft As Long = 0, _
        Optional ByVal lDestTop As Long = 0, _
        Optional ByVal lDestWidth As Long = -1, _
        Optional ByVal lDestHeight As Long = -1, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy, _
        Optional ByVal crTransparent As Long = -1 _
    )
   If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
   If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
   If Not (m_hDD = 0) Then
      ' DrawDib method:
      DrawDibDraw m_hDD, lhDC, lDestLeft, lDestTop, _
      lDestWidth, lDestHeight, _
       m_tBI, _
       ByVal m_lPtr, _
       lSrcLeft, lSrcTop, _
       lDestWidth, lDestHeight, 0
   Else
      If Not (crTransparent = -1) Then
         TransparentBlt lhDC, lDestLeft, lDestTop, _
            lDestWidth, lDestHeight, _
            m_hDC, _
            lSrcLeft, lSrcTop, _
            lDestWidth, lDestHeight, _
            crTransparent
      Else
         BitBlt lhDC, lDestLeft, lDestTop, _
            lDestWidth, lDestHeight, _
            m_hDC, _
            lSrcLeft, lSrcTop, eRop
      End If
   End If
End Sub
Public Sub AlphaPaintPicture( _
        ByVal lhDC As Long, _
        Optional ByVal lDestLeft As Long = 0, _
        Optional ByVal lDestTop As Long = 0, _
        Optional ByVal lDestWidth As Long = -1, _
        Optional ByVal lDestHeight As Long = -1, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal lConstantAlpha As Byte = 255 _
    )
   If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
   If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
   
   Dim lBlend As Long
   Dim bf As BLENDFUNCTION
   bf.BlendOp = AC_SRC_OVER
   bf.BlendFlags = 0
   bf.SourceConstantAlpha = lConstantAlpha
   bf.AlphaFormat = AC_SRC_ALPHA
   CopyMemory lBlend, bf, 4
   
   Dim lR As Long
   lR = AlphaBlend( _
      lhDC, _
      lDestLeft, lDestTop, lDestWidth, lDestHeight, _
      m_hDC, _
      lSrcLeft, lSrcTop, lDestWidth, lDestHeight, _
      lBlend)
   If (lR = 0) Then
      Debug.Print ApiError(Err.LastDllError)
   End If

End Sub
Public Property Get hDC() As Long
    hDC = m_hDC
End Property
Public Property Get hDIB() As Long
    hDIB = m_hDIB
End Property
Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property
Public Sub RandomiseBits( _
        Optional ByVal bGray As Boolean = False _
    )
Dim bDib() As Byte
Dim X As Long, Y As Long
Dim lC As Long
Dim tSA As SAFEARRAY2D
Dim xEnd As Long
    
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanline()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

    ' random:
    Randomize Timer
    
    xEnd = (Width - 1) * 3
    If (bGray) Then
        For Y = 0 To m_tBI.bmiHeader.biHeight - 1
            For X = 0 To xEnd Step 3
                lC = Rnd * 255
                bDib(X, Y) = lC
                bDib(X + 1, Y) = lC
                bDib(X + 2, Y) = lC
            Next X
        Next Y
    Else
        For X = 0 To xEnd Step 3
            For Y = 0 To m_tBI.bmiHeader.biHeight - 1
                bDib(X, Y) = 0
                bDib(X + 1, Y) = Rnd * 255
                bDib(X + 2, Y) = Rnd * 255
            Next Y
        Next X
    End If
    
    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    
End Sub

Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIB <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIB
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIB = 0: m_hBmpOld = 0: m_lPtr = 0
    If Not (m_hDD = 0) Then
      DrawDibClose m_hDD
      m_hDD = 0
   End If
End Sub

Public Function Resample( _
        ByVal lNewWidth As Long, _
        Optional ByVal lNewHeight As Long = -1 _
    ) As cDIBSection
   
   If (lNewHeight = -1) Then
      lNewHeight = (Height * lNewWidth) \ Width
   End If
   
   Dim cDib As cDIBSection
   Set cDib = New cDIBSection
   If cDib.Create(lNewWidth, lNewHeight) Then
      If (lNewWidth <> m_tBI.bmiHeader.biWidth) Or _
         (lNewHeight <> m_tBI.bmiHeader.biHeight) Then
         ' Change in size, do resample:
         ResampleDib cDib
      Else
         ' No size change so just return a copy:
         cDib.LoadPictureBlt m_hDC
      End If
      Set Resample = cDib
   End If
   
End Function

Private Function ResampleDib(ByRef cDibTo As cDIBSection) As Boolean
Dim bDibFrom() As Byte
Dim bDibTo() As Byte
Dim tSAFrom As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D

    ' Get the bits in the from DIB section:
    With tSAFrom
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanline()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4

    ' Get the bits in the to DIB section:
    With tSATo
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibTo.BytesPerScanline()
        .pvData = cDibTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4

Dim xScale As Single
Dim yScale As Single

Dim X As Long, Y As Long, xEnd As Long, xOut As Long

Dim fX As Single, fY As Single
Dim ifY As Long, ifX As Long
Dim DX As Single, DY As Single
Dim r As Long, R1 As Single, R2 As Single, r3 As Single, r4 As Single
Dim g As Long, G1 As Single, G2 As Single, g3 As Single, g4 As Single
Dim b As Long, b1 As Single, b2 As Single, b3 As Single, b4 As Single
Dim ir1 As Long, ig1 As Long, ib1 As Long
Dim ir2 As Long, ig2 As Long, ib2 As Long

    xScale = (Width - 1) / cDibTo.Width
    yScale = (Height - 1) / cDibTo.Height
    
    xEnd = cDibTo.Width - 1
        
    For Y = 0 To cDibTo.Height - 1
        
        fY = Y * yScale
        ifY = Int(fY)
        DY = fY - ifY
        
        For X = 0 To xEnd
            fX = X * xScale
            ifX = Int(fX)
            DX = fX - ifX
            
            ifX = ifX * 3
            ' Interpolate using the four nearest pixels in the source
            b1 = bDibFrom(ifX, ifY)
            G1 = bDibFrom(ifX + 1, ifY)
            R1 = bDibFrom(ifX + 2, ifY)
            b2 = bDibFrom(ifX + 3, ifY)
            G2 = bDibFrom(ifX + 4, ifY)
            R2 = bDibFrom(ifX + 5, ifY)
            b3 = bDibFrom(ifX, ifY + 1)
            g3 = bDibFrom(ifX + 1, ifY + 1)
            r3 = bDibFrom(ifX + 2, ifY + 1)
            b4 = bDibFrom(ifX + 3, ifY + 1): g4 = bDibFrom(ifX + 4, ifY + 1):
             r4 = bDibFrom(ifX + 5, ifY + 1)
            
            ' Interplate in x direction:
            ir1 = R1 * (1 - DY) + r3 * DY
            ig1 = G1 * (1 - DY) + g3 * DY
            ib1 = b1 * (1 - DY) + b3 * DY
            ir2 = R2 * (1 - DY) + r4 * DY
            ig2 = G2 * (1 - DY) + g4 * DY
            ib2 = b2 * (1 - DY) + b4 * DY
            ' Interpolate in y:
            r = ir1 * (1 - DX) + ir2 * DX
            g = ig1 * (1 - DX) + ig2 * DX
            b = ib1 * (1 - DX) + ib2 * DX
            
            ' Set output:
            If (r < 0) Then r = 0
            If (r > 255) Then r = 255
            If (g < 0) Then g = 0
            If (g > 255) Then g = 255
            If (b < 0) Then b = 0
            If (b > 255) Then
                b = 255
            End If
            xOut = X * 3
            bDibTo(xOut, Y) = b
            bDibTo(xOut + 1, Y) = g
            bDibTo(xOut + 2, Y) = r
            
        Next X
        
    Next Y

    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
    CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4


End Function

Private Sub Class_Terminate()
    ClearUp
End Sub