cimage.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cImage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
Option Base 0

'Class Name:    cImage.cls
'
'Description:   This class creates and gives access to a DIBSection for the
'               purpose of displaying and editing a digital image.
'

Private Type SAFEARRAYBOUND
    cElements         As Long
    lLbound           As Long
End Type
Private Type SAFEARRAY2D
    cDims             As Integer
    fFeatures         As Integer
    cbElements        As Long
    cLocks            As Long
    pvData            As Long
    Bounds(0 To 1)    As SAFEARRAYBOUND
End Type
Private Type RGBQUAD
    rgbBlue           As Byte
    rgbGreen          As Byte
    rgbRed            As Byte
    rgbReserved       As Byte
End Type
Private Type BITMAPINFOHEADER
    biSize            As Long
    biWidth           As Long
    biHeight          As Long
    biPlanes          As Integer
    biBitCount        As Integer
    biCompression     As Long
    biSizeImage       As Long
    biXPelsPerMeter   As Long
    biYPelsPerMeter   As Long
    biClrUsed         As Long
    biClrImportant    As Long
End Type
Private Type BITMAPFILEHEADER
    bfType            As Integer
    bfSize            As Long
    bfReserved1       As Integer
    bfReserved2       As Integer
    bfOffBits         As Long
End Type
Private Type BITMAP
    bmType            As Long
    bmWidth           As Long
    bmHeight          As Long
    bmWidthBytes      As Long
    bmPlanes          As Integer
    bmBitsPixel       As Integer
    bmBits            As Long
End Type
Private Type BITMAPINFO
    bmiHeader         As BITMAPINFOHEADER
    bmiColors(255)    As RGBQUAD
End Type
Private Type POINTAPI
        x As Long
        y As Long
End Type


Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long   'lplpVoid changed to ByRef
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


Private Const BLACKONWHITE    As Long = 1 'nStretchMode constants for
Private Const COLORONCOLOR    As Long = 3 '  SetStretchBltMode() API function
Private Const HALFTONE        As Long = 4 'HALFTONE not supported in Win 95, 98, ME

Private Const BI_RGB          As Long = 0&
Private Const BI_RLE4         As Long = 2&
Private Const BI_RLE8         As Long = 1&
Private Const DIB_RGB_COLORS  As Long = 0

Private m_hDIb        As Long       ' Handle to the current DIBSection
Private m_hBmpOld     As Long       ' Handle to the old bitmap in the DC, for clear up
Private m_hDC         As Long       ' Handle to the Device context holding the DIBSection
Private m_Ptr         As Long       ' Address of memory pointing to the DIBSection's bits
Private m_BI          As BITMAPINFO ' Type containing the Bitmap information
Private m_RGB(255)    As RGBQUAD



Private Sub Clear()
    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_Ptr = 0
End Sub
Private Sub Class_Terminate()
    Clear
End Sub



'====================================================================================
'                                PUBLIC PROPERTIES
'====================================================================================
Public Property Get Width() As Long
    Width = m_BI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_BI.bmiHeader.biHeight
End Property
Public Property Get BitCount() As Integer
    BitCount = m_BI.bmiHeader.biBitCount
End Property
Public Property Get hDC() As Long
    hDC = m_hDC
End Property
Public Property Get DIBitsPtr() As Long
    DIBitsPtr = m_Ptr
End Property
Public Property Get BytesPerScanLine() As Long
    Select Case m_BI.bmiHeader.biBitCount ' Scans must align on 4-byte boundaries
    Case 1:    BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 8 + 4) And &HFFFFFFFC
    Case 4:    BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 2 + 4) And &HFFFFFFFC
    Case 8:    BytesPerScanLine = (m_BI.bmiHeader.biWidth + 3) And &HFFFFFFFC
    Case Else: BytesPerScanLine = (m_BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
    End Select
End Property



'====================================================================================
'                             DIMENSION / COLOR DEPTH
'====================================================================================
Public Function Create(lWidth As Long, lHeight As Long, iBitCount As Integer) As Boolean
    Clear                        'Set Dimensions and BitCount in this cImage
    Select Case iBitCount
    Case 24
        m_hDC = CreateCompatibleDC(0)
    Case 1, 4, 8
        Dim lHDCDesk As Long
        lHDCDesk = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
        m_hDC = CreateCompatibleDC(lHDCDesk)
        DeleteDC lHDCDesk
    End Select
    If m_hDC = 0 Then Exit Function
    With m_BI.bmiHeader
        .biSize = Len(m_BI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = iBitCount
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    If iBitCount <> 24 Then ' Create a default grayscale palette
        Dim i As Long
        Dim c As Long
        c = 2 ^ iBitCount - 1
        For i = 0 To c
            With m_BI.bmiColors(i)
                .rgbBlue = i * 255# / c