cjpeg.cls

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

    For g = 0 To Vi - 1                  'Initialize .data pointers
        p(g) = 64 * h * g
    Next g
    pLF = 64 * h * (Vi - 1)              'Initialize .data pointer advancer

    MCUr = (h Mod Hi)                    'Number of complete 8X8 Blocks in rightmost MCU
    If MCUr = 0 Then MCUr = Hi

    For j = 1 To MCUy - 1

       'MCUs across a scanline
        For i = 1 To MCUx - 1
        For g = 1 To Vi
        For h = 1 To Hi

        Diff = data(p(g - 1)) - Pred
        Pred = data(p(g - 1))
        p(g - 1) = p(g - 1) + 64
        If Diff < 0 Then 's = number of bits needed for Diff
            s = Int((Log(-Diff) * 1.442695040889)) + 1   '1/log(2)  (+ error correction)
        ElseIf Diff > 0 Then
            s = Int((Log(Diff) * 1.442695040889)) + 1    '1/log(2) + (error correction)
        Else
            s = 0
        End If
        freqdc(s) = freqdc(s) + 1

        Next h
        Next g
        Next i

       'Rightmost MCU
        For g = 1 To Vi
        For h = 1 To Hi
        If h > MCUr Then  'Pad with dummy block
            s = 0
        Else
            Diff = data(p(g - 1)) - Pred
            Pred = data(p(g - 1))
            p(g - 1) = p(g - 1) + 64

            If Diff < 0 Then
                s = Int((Log(-Diff) * 1.442695040889)) + 1
            ElseIf Diff > 0 Then
                s = Int((Log(Diff) * 1.442695040889)) + 1
            Else
                s = 0
            End If
        End If
        freqdc(s) = freqdc(s) + 1
        Next h
        Next g

       'Advance data pointers
        For g = 0 To Vi - 1
            p(g) = p(g) + pLF
        Next g
    Next j


   'Bottommost MCU Scanline
    For i = 1 To MCUx
    For g = 1 To Vi
    For h = 1 To Hi
    If p(g - 1) >= n Or (i = MCUx And h > MCUr) Then 'Pad with dummy block
        s = 0
    Else
        Diff = data(p(g - 1)) - Pred
        Pred = data(p(g - 1))
        p(g - 1) = p(g - 1) + 64

        If Diff < 0 Then
            s = Int((Log(-Diff) * 1.442695040889)) + 1
        ElseIf Diff > 0 Then
            s = Int((Log(Diff) * 1.442695040889)) + 1
        Else
            s = 0
        End If
    End If
    freqdc(s) = freqdc(s) + 1
    Next h
    Next g
    Next i

End Sub




'========================================================================================
'                                Q U A N T I Z A T I O N
'========================================================================================
Private Sub ExpandDQT(Tqi As Long)
    Dim i          As Long
    Dim j          As Long
    Dim k          As Byte
    Dim maxvalue   As Long

    With QTable(Tqi)
        If PP = 12 Then
            maxvalue = 65535
        Else
            maxvalue = 255
        End If

        For i = 0 To 7
            For j = 0 To 7
                k = ZigZag(i, j)
                If .Qk(k) < 1 Or .Qk(k) > maxvalue Then Err.Raise 1, , "Bad Quantization Table"
               .FScale(k) = FDCTScale(i) * FDCTScale(j) / CDbl(.Qk(k))
            Next j
        Next i
    End With

End Sub
Private Sub Quantize(data() As Integer, p As Long, FScale() As Single)
    Dim i As Long  'Take 8X8 block of unscaled DCT coefficients [m_Block(0-7, 0-7)],
    Dim j As Long  'Scale, Quantize, and store the results in data() array of
    Dim t As Long  'COMPONENT in Zig Zag order at index p


    For j = 0 To 7
        For i = 0 To 7
            t = ZigZag(i, j)
            data(p + t) = m_Block(i, j) * FScale(t)
        Next i
    Next j
    p = p + 64

End Sub
Public Property Let Quality(vData As Long)
'The JPEG compression standard does not have a formal definition for image Quality.
'This implementation defines Quality as an integer value between 1 and 100, and
'generates quantization tables based on the value given.
'
'Quality < 50  -  Poor image quality with high compression
'Quality = 75  -  Good quality pictures for displaying on a monitor or web page ... typical for general use
'Quality = 92  -  High quality with non-optimal compression ... Appropriate for printing ... [typical digital camera "max quality" setting]
'Quality > 95  -  Wasteful ... very poor compression with little image quality improvement.  Use 24-bit BMP TrueColor if you need quality this high.

    Dim i           As Long
    Dim qvalue      As Long
    Dim maxvalue    As Long
    Dim scalefactor As Long

    maxvalue = 255 '32767 if 16 bit quantum is allowed

    If vData > 0 And vData <= 100 Then
        m_Quality = vData

        If (m_Quality < 50) Then
            If m_Quality <= 0 Then
                scalefactor = 5000
            Else
                scalefactor = 5000 / m_Quality
            End If
        Else
            If m_Quality > 100 Then
                scalefactor = 0
            Else
                scalefactor = 200 - m_Quality * 2
            End If
        End If

        With QTable(0)
            For i = 0 To 63
                qvalue = (QLumin(i) * scalefactor + 50) / 100
                If qvalue <= 0 Then
                    qvalue = 1
                ElseIf qvalue > maxvalue Then
                    qvalue = maxvalue
                End If
                .Qk(i) = qvalue
            Next i
        End With
        With QTable(1)
            For i = 0 To 63
                qvalue = (QChrom(i) * scalefactor + 50) / 100
                If qvalue <= 0 Then
                    qvalue = 1
                ElseIf qvalue > maxvalue Then
                    qvalue = maxvalue
                End If
                .Qk(i) = qvalue
            Next i
        End With

        ExpandDQT 0
        ExpandDQT 1
    End If

End Property
Public Property Get Quality() As Long
    Quality = m_Quality
End Property





'================================================================================
'                           I M A G E   S A M P L I N G
'================================================================================
Public Sub SetSamplingFrequencies(H1 As Long, V1 As Long, H2 As Long, V2 As Long, H3 As Long, V3 As Long)

'This class always samples and compresses pictures in YCbCr colorspace.  The first component, Y,
'represents the Luminance of the pixels.  This is "how bright" a pixel is.  The Cb and Cr
'components are Chrominance, which is a measure of how far from neutral-white (toward a color)
'a pixel is.  The human visual sensory system can discriminate Luminance differences about
'twice as well as it can discriminate Chrominance differences.
'
'Virtually all JPEG files are in YCbCr colorspace.  Other JPEG compliant colorspaces exist, but
'they are used in specialty equipment.  For example, people in the astronomy or medical fields
'choose colorspaces that best record the information they are interested in, and don't care about
'how pretty the picture looks to a person when displayed on a computer monitor.
'[Apple/Machintosh sometimes uses a four component colorspace, but that colorspace is rare and
'not widely supported]
'
'Sampling frequencies define how often each component is sampled.  Higher frequencies store more
'information, while lower frequencies store less.  Typically, sampling frequencies are set at
'2,2, 1,1, 1,1.  This corresponds to the human visual sensory system.  The first component,
'Luminance, is sampled twice as much because our eyes notice differences in Luminance quite easily.
'The two Chrominance components are sampled half as much as because our eyes can't distinguish
'the difference in color changes as well.  One Luminance value is sampled for every pixel, and
'one Chrominance value is sampled for each 2X2 block of pixels.
'
'Digital cameras typically record at sampling frequencies of 1,1, 1,1, 1,1.  This samples every
'pixel for all three components.  The quality of the picture is a little better when viewed by
'a person, but the compression benefits drop significantly.  If the picture to be compressed
'is from a Scanner or Digital camera, and you plan on printing it in the future, and storage
'space is not a problem, then sampling at these frequencies makes sense.  Otherwise, if you only
'plan on using the picture to display on a monitor or a web page, [2,2, 1,1, 1,1] makes the
'most sense.
'
'The JPEG standard specifies that sampling frequencies may range from 1-4 for each component
'in both directions.  However, if any component has a sampling frequency of '3', and another
'component has a coresponding sampling frequency of '2' or '4', the downsampling process
'will map fractional pixels to sample values.  This is leagal in the JPEG standard, and this
'class will compress fractional pixel samplings, but this is not widely supported.  It is
'highly recommended to AVOID SAMPLING FACTORS OF 3 for maximum compatability with JPEG decoders.
'
'Some JPEG encoders avoid the fractional pixel problem by only allowing the end user to pick
'a "sub-sampling" value.  In such "Sub Sampling" schemes, all Chrominance frequencies are set
'to one, and the (one or two) sub-sampling value(s) specify Luminance frequencies.
'
'There should *never* be an error raised if you are using this class correctly.  It should
'not be possible for the end user to specify illegal sampling frequency values!
'[For tinkerers - If you delete the error raising code and specify illegal sampling
'frequencies, this class will procede to create a non-JPEG compliant file with the values
'specified]

    Dim i As Long

    If H1 < 1 Or H1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
    If V1 < 1 Or V1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"

    If (H2 Or H3 Or V2 Or V3) = 0 Then  'if H2,H3,V2,V3 are all zero ...
        Nf = 1         'Luminance only.
        ReDim Comp(0)
        Comp(0).Hi = 1 'Set up for sampling Greyscale
        Comp(0).Vi = 1 '(Black and White picture)
    Else
        If H2 < 1 Or H2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
        If H3 < 1 Or H3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
        If V2 < 1 Or V2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
        If V3 < 1 Or V3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
        Nf = 3         'YCbCr
        ReDim Comp(2)
        Comp(0).Hi = H1
        Comp(0).Vi = V1
        Comp(0).Tqi = 0
        Comp(1).Hi = H2
        Comp(1).Vi = V2
        Comp(1).Tqi = 1
        Comp(2).Hi = H3
        Comp(2).Vi = V3
        Comp(2).Tqi = 1
    End If

    HMax = -1
    VMax = -1
    For i = 0 To Nf - 1 'determine max h, v sampling factors
        If HMax < Comp(i).Hi Then HMax = Comp(i).Hi
        If VMax < Comp(i).Vi Then VMax = Comp(i).Vi
    Next i

End Sub

Public Function SampleHDC(ByVal lHDC As Long, lWidth As Long, lHeight As Long, Optional lSrcLeft As Long, Optional lSrcTop As Long) As Long
'Given a valid hDC and dimensions, generate component samplings of an Image.
'A DIBSection is created to hold Sample(s) of the Image, from which the Image is
'decomposed into YCbCr components.
'Returns: 0 = Success
'         1 = API error while generating a DIBSection
    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