cjpeg.cls

打印预览程序

'/***********************************************************

    Dim hDIb       As Long    'Handle to the DIBSection
    Dim hBmpOld    As Long    'Handle to the old bitmap in the DC, for clear up
    Dim hDC        As Long    'Handle to the Device context holding the DIBSection
    Dim lPtr       As Long    'Address of memory pointing to the DIBSection's bits
    Dim BI         As BITMAPINFO 'Type containing the Bitmap information
    Dim SA         As SAFEARRAY2D
    Dim Pixel()    As Byte   'Byte array containing pixel data
    Dim f          As Long   'Index counter for components
    Dim qp         As Long   'Index for quantized FDCT value (in component data)
    Dim rm         As Single 'Scale factor for red   pixel when converting RGB->YCbCr
    Dim gm         As Single 'Scale factor for green pixel when converting RGB->YCbCr
    Dim bm         As Single 'Scale factor for blue  pixel when converting RGB->YCbCr
    Dim s          As Single 'Level shift value             for converting RGB->YCbCr
    Dim xi         As Long   'Sample width
    Dim yi         As Long   'Sample height
    Dim xi2        As Long   'Sample width  (for previous component)
    Dim yi2        As Long   'Sample height (for previous component)
    Dim xi8        As Long   'Sample width  (padded to 8 pixel barrier)
    Dim yi8        As Long   'Sample height (padded to 8 pixel barrier)
    Dim i0         As Long   'Left index of an 8X8 block of pixels
    Dim j0         As Long   'Top  index of an 8X8 block of pixels
    Dim i          As Long   'Pixel Index (Horizontal)
    Dim j          As Long   'Pixel Index (Vertical)
    Dim p          As Long   'DCT Index (horizontal)
    Dim q          As Long   'DCT Index (vertical)


    PP = 8
    YY = lHeight
    XX = lWidth

   'Create a DIBSection to store Sampling(s) of the Image
    hDC = CreateCompatibleDC(0)
    If hDC = 0 Then
        SampleHDC = 1 'CreateCompatibleDC() API Failure
    Else
        With BI.bmiHeader
            .biSize = Len(BI.bmiHeader)
            .biWidth = (lWidth + 7) And &HFFFFFFF8   '8 byte barrier for 8X8 data units
            .biHeight = (lHeight + 7) And &HFFFFFFF8
            .biPlanes = 1
            .biBitCount = 24
            .biCompression = BI_RGB
            .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight '4 byte barrier
        End With
        hDIb = CreateDIBSection2(hDC, BI, DIB_RGB_COLORS, lPtr, 0, 0)
        If hDIb = 0 Then
            SampleHDC = 1 'CreateDIBSection2() API Failure
        Else
            With SA                        'This code copies the pointer of the 2-D bitmap
                .cbElements = 1            'pixel data to the pointer of the Pixel() array.
                .cDims = 2                 'This allows you to read/modify the pixel data
                .Bounds(0).lLbound = 0     'as if it were stored in the Pixel() array.
                .Bounds(0).cElements = BI.bmiHeader.biHeight
                .Bounds(1).lLbound = 0
                .Bounds(1).cElements = ((BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC)
                .pvData = lPtr             'Note that this is extreamly efficient, since it copies
            End With                       'a pointer to the data, and not the data itself.
            hBmpOld = SelectObject(hDC, hDIb) 'Select DIBSection into DC
            If SetStretchBltMode(hDC, HALFTONE) = 0 Then SetStretchBltMode hDC, COLORONCOLOR


    For f = 0 To Nf - 1
        Select Case f 'Select scaling factors for RGB->YCbCr conversion for this component
        Case 0 'Luminance
            rm = 0.299
            gm = 0.587
            bm = 0.114
            s = -128
        Case 1 'Chrominance [Blue-Yellow]
            rm = -0.16874
            gm = -0.33126
            bm = 0.5
            s = 0
        Case 2 'Chrominance [Red-Green]
            rm = 0.5
            gm = -0.41869
            bm = -0.08131
            s = 0
        End Select

        With Comp(f)
           .Ci = f + 1 'Assign an ID to this component

            xi = -Int(-XX * .Hi / HMax)        'determine Sample dimensions
            yi = -Int(-YY * .Vi / VMax)
            xi8 = ((xi + 7) And &HFFFFFFF8)    'Sample dimensions with 8X8 barrier
            yi8 = ((yi + 7) And &HFFFFFFF8)
            ReDim .data(xi8 * yi8 - 1)

            If xi8 <> xi2 Or yi8 <> yi2 Then  'We need to Sample the Image
                If xi = XX And yi = YY Then 'Just copy the image to our DIBSection
                    BitBlt hDC, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, vbSrcCopy
                Else                        'Resample/Resize the Image
                    StretchBlt hDC, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, lWidth, lHeight, vbSrcCopy
                End If
                For i = xi To xi8 - 1  'Pad right of Sample to 8 block barrier
                    BitBlt hDC, i, BI.bmiHeader.biHeight - yi8, 1, yi, hDC, i - 1, BI.bmiHeader.biHeight - yi8, vbSrcCopy
                Next i
                For j = BI.bmiHeader.biHeight - (yi8 - yi) To BI.bmiHeader.biHeight - 1 'Pad bottom of Sample to 8 block barrier
                    BitBlt hDC, 0, j, xi8, 1, hDC, 0, j - 1, vbSrcCopy
                Next j
            End If
            xi2 = xi8
            yi2 = yi8
            qp = 0 'Reset output Quantized FDCT Coefficient Index

           'Read 8X8 blocks of pixels, convert from RGB->YCbCr colorspace, FDCT and Quantize
           'the data, store the results in .data of this component
            CopyMemory ByVal VarPtrArray(Pixel), VarPtr(SA), 4& 'Get Pixel array descriptor
            j = yi8 - 1
            While j > 0               'Scan from top to bottom (j = -1 after loop)
                i = 0
                j0 = j
                While i < 3 * xi8     'Scan from left to right (i = 3*xi8 after loop)
                    j = j0
                    i0 = i
                    For p = 0 To 7    'Get 8X8 block of level shifted YCbCr values
                        i = i0
                        For q = 0 To 7
                            m_Block(q, p) = rm * Pixel(i + 2, j) + _
                                            gm * Pixel(i + 1, j) + _
                                            bm * Pixel(i, j) + s
                            i = i + 3
                        Next q
                        j = j - 1
                    Next p
                    FDCT                               'Calculate the FDCT
                    Quantize .data, qp, QTable(.Tqi).FScale   'Quantize, and store in DCT buffer
                Wend
            Wend
            CopyMemory ByVal VarPtrArray(Pixel), 0&, 4 'Clear the Pixel array descriptor
        End With
    Next f


            SelectObject hDC, hBmpOld 'Select CompatibleDC  (unselect DIBSection)
            DeleteObject hDIb         'Delete DIBSection
        End If
        DeleteObject hDC              'Delete CompatibleDC
    End If

End Function



Public Property Let Comment(Value As String)
   'Assigning a value to this property will add the text Comment to the JPEG file.
    If Len(Value) > 65535 Then Err.Raise 1, , "Illegal Comment Length"
    m_Comment = Value
End Property
Public Property Get Comment() As String
    Comment = m_Comment
End Property




'================================================================================
'                         E M I T I N G   M A R K E R S
'================================================================================
Private Sub InsertJFIF()
    If m_Ptr + 17 > UBound(m_Data) Then Err.Raise 9 'Copymemory will write past bounds of m_Data()

    CopyMemory m_Data(m_Ptr + 0), &H1000E0FF, 4&    'APP0 Marker, Length(APP0)=16
    CopyMemory m_Data(m_Ptr + 4), &H4649464A, 4&    '"JFIF"
    CopyMemory m_Data(m_Ptr + 8), &H10100, 4&       '"/0", Version Major=1, Version Minor=1
                                                    'Units=0  [0=pixel, 1=dpi, 2=dots/cm]
    CopyMemory m_Data(m_Ptr + 12), &H1000100, 4&    'Horizontal pixel density = 1 (dot per pixel)
                                                    'Vertical   pixel density = 1 (dot per pixel)
    CopyMemory m_Data(m_Ptr + 16), &H0&, 2&         'Thumbnail horizontal pixel count = 0
    m_Ptr = m_Ptr + 18                              'Thumbnail vertical   pixel count = 0

End Sub
Private Sub InsertSOF(SOFMarker As Long)
    Dim i   As Long 'Insert a Start Of Frame marker segment
    Dim Lx  As Long 'PP, YY, XX, Nf, and Ci,Hi,Vi,Tqi, must already be set

    Lx = 8 + 3 * Nf
    m_Data(m_Ptr) = 255                    'SOF
    m_Data(m_Ptr + 1) = SOFMarker And 255
    m_Data(m_Ptr + 2) = Lx \ 256           'Frame Header Length
    m_Data(m_Ptr + 3) = Lx And 255
    m_Data(m_Ptr + 4) = PP                 'Sample precision [8, 12]
    m_Data(m_Ptr + 5) = YY \ 256           'Number of Lines
    m_Data(m_Ptr + 6) = YY And 255
    m_Data(m_Ptr + 7) = XX \ 256           'Number of samples per line
    m_Data(m_Ptr + 8) = XX And 255
    m_Data(m_Ptr + 9) = Nf                 'Number of image components in frame
    m_Ptr = m_Ptr + 10
    For i = 0 To Nf - 1                      'For each component ...
        With Comp(i)
            m_Data(m_Ptr) = .Ci                  'Component identifier
            m_Data(m_Ptr + 1) = .Hi * 16 Or .Vi  'Horizontal/Vertical sampling factors
            m_Data(m_Ptr + 2) = .Tqi             'Quantization table selector
        End With
        m_Ptr = m_Ptr + 3
    Next i
End Sub
Private Sub InsertCOM(TheComment As String)
    Dim i As Long
    Dim Lx As Long

    Lx = Len(TheComment) + 2
    If Lx > 2 Then
        m_Data(m_Ptr) = 255               'COM marker
        m_Data(m_Ptr + 1) = COM
        m_Data(m_Ptr + 2) = Lx \ 256      'COM marker segment length
        m_Data(m_Ptr + 3) = Lx And 255
        m_Ptr = m_Ptr + 4
        For i = 1 To Len(TheComment)      'Comment text
            m_Data(m_Ptr) = Asc(Mid$(TheComment, i, 1))
            m_Ptr = m_Ptr + 1
        Next i
    End If
End Sub
Private Sub InsertDQT(ByVal MarkerPos As Long, Tqi As Long)
    Dim i As Long 'Call with MarkerPos = m_Ptr to insert a single table with its own DQT marker
                  'Call multiple times with the same MarkerPos to include
                  'multiple tables under the same DQT marker

    If m_Ptr < MarkerPos + 4 Then 'Insert Marker
        m_Ptr = MarkerPos + 4
        m_Data(m_Ptr - 4) = 255
        m_Data(m_Ptr - 3) = DQT
    End If
    With QTable(Tqi)
        For i = 0 To 63
            If .Qk(i) > 255 Then Exit For
        Next i
        If i = 64 Then              '8 bit precision
            m_Data(m_Ptr) = Tqi
            m_Ptr = m_Ptr + 1
            For i = 0 To 63
                m_Data(m_Ptr) = .Qk(i)
                m_Ptr = m_Ptr + 1
            Next i
        Else                        '16 bit precision
            If PP <> 12 Then Err.Raise 1, , "Illegal precission in Quantization Table"
            m_Data(m_Ptr) = Tqi Or 16
            m_Ptr = m_Ptr + 1
            For i = 0 To 63
                m_Data(m_Ptr) = .Qk(i) \ 256
                m_Data(m_Ptr + 1) = .Qk(i) And 255
                m_Ptr = m_Ptr + 2
            Next i
        End If
    End With

    m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256& 'Insert Marker segment length
    m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
End Sub
Private Sub InsertDHT(ByVal MarkerPos As Long, HIndex As Long, IsAC As Boolean)
    Dim i As Long 'Call with MarkerPos = m_Ptr to insert a single table with its own DHT marker
    Dim j As Long 'Call multiple times with the same MarkerPos to include
                  'multiple tables under the same DHT marker

    If m_Ptr < MarkerPos + 4 Then 'Insert Marker
        m_Ptr = MarkerPos + 4
        m_Data(m_Ptr - 4) = 255
        m_Data(m_Ptr - 3) = DHT
    End If
    If IsAC Then
        With HuffAC(HIndex)
            m_Data(m_Ptr) = HIndex Or 16
            m_Ptr = m_Ptr + 1
            j = 0
            For i = 0 To 15
                m_Data(m_Ptr) = .BITS(i)
                m_Ptr = m_Ptr + 1
                j = j + .BITS(i)
            Next i
            For i = 0 To j - 1
                m_Data(m_Ptr) = .HUFFVAL(i)
                m_Ptr = m_Ptr + 1
            Next i
        End With
    Else
        With HuffDC(HIndex)
            m_Data(m_Ptr) = HIndex
            m_Ptr = m_Ptr + 1
            j = 0
            For i = 0 To 15
                m_Data(m_Ptr) = .BITS(i)
                m_Ptr = m_Ptr + 1
                j = j + .BITS(i)
            Next i
            For i = 0 To j - 1
                m_Data(m_Ptr) = .HUFFVAL(i)
                m_Ptr = m_Ptr + 1
            Next i
        End With
    End If

    m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256& 'Insert Marker segment length
    m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
End Sub
Private Sub InsertMarker(TheMarker As Long)
    m_Data(m_Ptr) = 255
    m_Data(m_Ptr + 1) = TheMarker
    m_Ptr = m_Ptr + 2
End Sub




'================================================================================
'                           E M I T I N G   S C A N S
'================================================================================
Private Sub InsertSOSNonInterleaved(CompIndex As Long, Td As Long, Ta As Long)
'Insert an SOS marker and scan data for a non-interleaved Sequential scan.
    Dim p         As Long     'Index to .data in component
    Dim n         As Long
    Dim Pred      As Long     'Predictor for DC coefficient


   'Insert SOS Marker Segment
    m_Data(m_Ptr) = 255                          'SOS Marker
    m_Data(m_Ptr + 1) = SOS
    m_Data(m_Ptr + 2) = 8 \ 256                  'Marker Segment Length