cimage.cls

BMP转换为JGP源码,不使用第三方控件

                .rgbGreen = .rgbBlue
                .rgbRed = .rgbBlue
            End With
        Next i
    End If
    m_hDIb = CreateDIBSection2(m_hDC, m_BI, DIB_RGB_COLORS, m_Ptr, 0, 0)
    If m_hDIb = 0 Then
        DeleteObject m_hDC
    Else
        m_hBmpOld = SelectObject(m_hDC, m_hDIb)
        Create = True
    End If
End Function



'====================================================================================
'                                 LOAD/COPY IMAGE
'====================================================================================
Public Function CopyStdPicture(ByRef TheStdPicture As StdPicture, Optional iBitCount As Integer) As Boolean
    Dim lHDC         As Long
    Dim lhDCDesktop  As Long
    Dim lhBmpOld     As Long
    Dim tBMP         As BITMAP
    Dim CopyPalette  As Boolean

    GetObjectAPI TheStdPicture.handle, Len(tBMP), tBMP

    CopyPalette = (iBitCount = 0)
    If CopyPalette Then
        iBitCount = tBMP.bmBitsPixel
        If iBitCount = 16 Then iBitCount = 24
    End If

    If Not Create(tBMP.bmWidth, tBMP.bmHeight, iBitCount) Then Exit Function

    If m_BI.bmiHeader.biBitCount = 24 Then
        lhDCDesktop = GetDC(GetDesktopWindow())
    Else
        lhDCDesktop = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    End If
    If lhDCDesktop = 0 Then Exit Function

    lHDC = CreateCompatibleDC(lhDCDesktop)
    DeleteDC lhDCDesktop
    If lHDC = 0 Then Exit Function
    lhBmpOld = SelectObject(lHDC, TheStdPicture.handle)
    If m_BI.bmiHeader.biBitCount = 24 Then
        BitBlt m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, lHDC, 0, 0, vbSrcCopy
    Else
        If CopyPalette Then
            Dim lC As Long
            Dim C2 As Long
            C2 = 2 ^ m_BI.bmiHeader.biBitCount
            lC = GetDIBColorTable(lHDC, 0, C2, m_RGB(0))
            If (lC > 0) Then SetDIBColorTable m_hDC, 0, lC, m_RGB(0)
        End If
        GetDIBits256 lHDC, TheStdPicture.handle, 0, tBMP.bmHeight, ByVal m_Ptr, m_BI, DIB_RGB_COLORS
    End If
    SelectObject lHDC, lhBmpOld
    DeleteObject lHDC
    CopyStdPicture = True
End Function
Public Function CopyHDC(ByVal lHDC As Long, lWidth As Long, lHeight As Long, Optional ByVal iBitCount As Integer, Optional lSrcLeft As Long, Optional lSrcTop As Long) As Boolean
    Dim C1 As Long
    If iBitCount = 0 Then
        C1 = GetDIBColorTable(lHDC, 0, 256, m_RGB(0))
        Select Case C1
        Case 1 To 2:     iBitCount = 1
        Case 3 To 16:    iBitCount = 4
        Case 17 To 256:  iBitCount = 8
        Case Else:       iBitCount = 24
        End Select
    End If
    If Not Create(lWidth, lHeight, iBitCount) Then Exit Function
    If C1 > 0 Then SetDIBColorTable m_hDC, 0, C1, m_RGB(0)
    BitBlt m_hDC, 0, 0, lWidth, lHeight, lHDC, lSrcLeft, lSrcTop, vbSrcCopy
    CopyHDC = True
End Function

Public Function CopyPalletHDC(ByVal lHDC As Long) As Boolean
    Dim g As Long

    g = GetDIBColorTable(lHDC, 0, 2 ^ m_BI.bmiHeader.biBitCount, m_RGB(0))
    If g > 0 Then CopyPalletHDC = (g = SetDIBColorTable(m_hDC, 0, g, m_RGB(0)))
End Function



'====================================================================================
'                              PAINT/PASTE SECTIONS
'====================================================================================
Public Sub PaintHDC(lHDC As Long, Optional lDestLeft As Long, Optional lDestTop As Long, Optional eRop As RasterOpConstants = vbSrcCopy)
    BitBlt lHDC, lDestLeft, lDestTop, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_hDC, 0, 0, eRop
End Sub



'====================================================================================
'                               DISPLAY FUNCTIONS
'====================================================================================
'The following functions return modified versions of this class for display purposes.
'They are not meant to be used as reliable image processing routines, because the
'PlgBlt() and StretchBlt() API calls are not precise.

Public Function Greyscale() As cImage
    Set Greyscale = New cImage        'Return 8 bit Greyscale version of this cImage
    Greyscale.Create m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 8
    BitBlt Greyscale.hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_hDC, 0, 0, vbSrcCopy
End Function

Public Function Resample(lWidth As Long, lHeight As Long) As cImage
    Set Resample = New cImage         'Return a resized version of this cImage
    Resample.Create lWidth, lHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Resample.CopyPalletHDC m_hDC

    If (lWidth = m_BI.bmiHeader.biWidth) And (lHeight = m_BI.bmiHeader.biHeight) Then
       'Just return a copy
        BitBlt Resample.hDC, 0, 0, lWidth, lHeight, m_hDC, 0, 0, vbSrcCopy
    Else
       'HALFTONE gives better quality at slower speed, but it's unsupported in Win 95, 98, ME.
       'If we can't use HALFTONE, use COLORONCOLOR.  The default BLACKONWHITE is unacceptable.
        If SetStretchBltMode(Resample.hDC, HALFTONE) = 0 Then SetStretchBltMode Resample.hDC, COLORONCOLOR
        StretchBlt Resample.hDC, 0, 0, lWidth, lHeight, m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, vbSrcCopy
    End If
End Function

Public Function Mirror(Vertical As Boolean) As cImage
    Dim MyPoint(2) As POINTAPI 'Return a mirror image of this cImage

    If Vertical Then
        MyPoint(0).x = 0
        MyPoint(0).y = m_BI.bmiHeader.biHeight
        MyPoint(1).x = m_BI.bmiHeader.biWidth
        MyPoint(1).y = m_BI.bmiHeader.biHeight
        MyPoint(2).x = 0
        MyPoint(2).y = 0
    Else
        MyPoint(0).x = m_BI.bmiHeader.biWidth
        MyPoint(0).y = 0
        MyPoint(1).x = 0
        MyPoint(1).y = 0
        MyPoint(2).x = m_BI.bmiHeader.biWidth
        MyPoint(2).y = m_BI.bmiHeader.biHeight
    End If

    Set Mirror = New cImage
    Mirror.Create m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Mirror.CopyPalletHDC m_hDC
    PlgBlt Mirror.hDC, MyPoint(0), m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 0, 0, 0
End Function

Public Function Rotate(ByVal Degrees As Long) As cImage
    Dim NewWidth     As Long 'Return version of this cImage rotated Degrees
    Dim NewHeight    As Long
    Dim MyPoint(2)   As POINTAPI

    Degrees = Degrees Mod 360
    If Degrees < 0 Then Degrees = Degrees + 360

    Select Case Degrees
    Case 90
        MyPoint(0).x = 0
        MyPoint(0).y = m_BI.bmiHeader.biWidth
        MyPoint(1).x = 0
        MyPoint(1).y = 0
        MyPoint(2).x = m_BI.bmiHeader.biHeight
        MyPoint(2).y = m_BI.bmiHeader.biWidth
        NewWidth = m_BI.bmiHeader.biHeight
        NewHeight = m_BI.bmiHeader.biWidth
    Case 180
        MyPoint(0).x = m_BI.bmiHeader.biWidth
        MyPoint(0).y = m_BI.bmiHeader.biHeight
        MyPoint(1).x = 0
        MyPoint(1).y = m_BI.bmiHeader.biHeight
        MyPoint(2).x = m_BI.bmiHeader.biWidth
        MyPoint(2).y = 0
        NewWidth = m_BI.bmiHeader.biWidth
        NewHeight = m_BI.bmiHeader.biHeight
    Case 270
        MyPoint(0).x = m_BI.bmiHeader.biHeight
        MyPoint(0).y = 0
        MyPoint(1).x = m_BI.bmiHeader.biHeight
        MyPoint(1).y = m_BI.bmiHeader.biWidth
        MyPoint(2).x = 0
        MyPoint(2).y = 0
        NewWidth = m_BI.bmiHeader.biHeight
        NewHeight = m_BI.bmiHeader.biWidth
    Case Else
        Exit Function
    End Select

    Set Rotate = New cImage
    Rotate.Create NewWidth, NewHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Rotate.CopyPalletHDC m_hDC
    PlgBlt Rotate.hDC, MyPoint(0), m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 0, 0, 0
End Function