cjpeg.cls

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

                    End If
                End If
            End If
        Next i
        If V2 = -1 Then
            freq(V1) = 0 'all elements in freq are now set to zero
            Exit Do      'done
        End If
        freq(V1) = freq(V1) + freq(V2)     'merge the two branches
        freq(V2) = 0
        codesize(V1) = codesize(V1) + 1    'Increment all codesizes in v1's branch
        While (others(V1) >= 0)
            V1 = others(V1)
            codesize(V1) = codesize(V1) + 1
        Wend
        others(V1) = V2                    'chain v2 onto v1's branch
        codesize(V2) = codesize(V2) + 1    'Increment all codesizes in v2's branch
        While (others(V2) >= 0)
            V2 = others(V2)
            codesize(V2) = codesize(V2) + 1
        Wend
    Loop

   'Count BITS  [find the number of codes of each size]
    n = 0
    For i = 0 To 256
        If codesize(i) <> 0 Then
            BITS(codesize(i)) = BITS(codesize(i)) + 1
            If n < codesize(i) Then n = codesize(i)    'Keep track of largest codesize
        End If
    Next i

   'Adjust BITS  [limit code lengths to 16 bits]
    i = n
    While i > 16
        While BITS(i) > 0
            For j = i - 2 To 1 Step -1        'Since symbols are paired for the longest Huffman
                If BITS(j) > 0 Then Exit For  'code, the symbols are removed from this length
            Next j                            'category two at a time.  The prefix for the pair
            BITS(i) = BITS(i) - 2             '(which is one bit shorter) is allocated to one
            BITS(i - 1) = BITS(i - 1) + 1     'of the pair;  then, (skipping the BITS entry for
            BITS(j + 1) = BITS(j + 1) + 2     'that prefix length) a code word from the next
            BITS(j) = BITS(j) - 1             'shortest non-zero BITS entry is converted into
        Wend                                  'a prefix for two code words one bit longer.
        i = i - 1
    Wend
    BITS(i) = BITS(i) - 1                  'Remove dummy symbol code from the code length count

   'Copy BITS and HUFFVAL to the HUFFMANTABLE  [HUFFVAL sorted by code length, then by value]
    With TheHuff
        For i = 1 To 16
            .BITS(i - 1) = BITS(i)
        Next i
        k = 0
        For i = 1 To n
            For j = 0 To 255
                If codesize(j) = i Then
                    .HUFFVAL(k) = j
                    k = k + 1
                End If
            Next j
        Next i
    End With

End Sub
Private Sub ExpandHuffman(TheHuff As HUFFMANTABLE, Optional MaxSymbol As Long = 255)
'Given a HUFFMANTABLE with valid BITS and HUFFVAL, generate tables for
'EHUFCO, EHUFSI, MAXCODE, and MINCODE so the table may be used for compression
'and/or decompression.  In JPEG, MaxSymbol is 255 for an AC Huffman Table.  For
'DC Tables, MaxSymbol is 11 for PP=8 bit precission, or 15 for PP=12 bit precission.
    Dim i          As Long 'Index for BITS
    Dim j          As Long 'Index for HUFFVAL
    Dim k          As Long 'Index for last HUFFVAL of length (i+1)
    Dim si         As Long 'Huffman code size  ( =2^i )
    Dim code       As Long 'Huffman code
    Dim symbol     As Long 'Huffman symbol


    With TheHuff

        For i = 0 To 255
           .EHUFSI(i) = 0      'Clear existing values so we can
           .EHUFCO(i) = -1     'check for duplicate huffman symbols
        Next i

        j = 0
        si = 1
        code = 0
        For i = 0 To 15
            k = j + .BITS(i)
            If k > 256 Then Err.Raise 1, , "Bad Huffman Table" 'more than 256 symbols
            If j = k Then 'no codes of length i+1
               .MINCODE(i) = j - code
               .MAXCODE(i) = -1
            Else
               .MINCODE(i) = j - code
                While j < k
                    symbol = .HUFFVAL(j)  'read symbol, make sure it's valid
                    If symbol > MaxSymbol Then Err.Raise 1, , "Bad Huffman Table"   'invalid symbol
                    If .EHUFCO(symbol) >= 0 Then Err.Raise 1, , "Bad Huffman Table" 'duplicate symbol
                   .EHUFSI(symbol) = si    'assign code for symbol
                   .EHUFCO(symbol) = code
                    code = code + 1
                    j = j + 1
                Wend
               .MAXCODE(i) = code - 1
            End If
            si = si * 2
            If code >= si Then Err.Raise 1, , "Bad Huffman Table" 'code does not fit into available bits
            code = code * 2
        Next i
        If j = 0 Then Err.Raise 1, , "Bad Huffman Table" 'No huffman symbols???
    End With

End Sub




'================================================================================
'                           E N T R O P Y   C O D I N G
'================================================================================
Private Sub WriteBitsBegin()
    m_Chr = 0
    m_Bit = 128
End Sub
Private Sub WriteBitsEnd()
    If m_Bit <> 128 Then WriteBits m_Bit, -1
End Sub
Private Sub WriteBits(ByVal si As Long, code As Long)
    While si > 0
        If (code And si) <> 0 Then m_Chr = (m_Chr Or m_Bit)
        If m_Bit = 1 Then            'We completed a byte ...
            m_Data(m_Ptr) = m_Chr    '    add it to the stream
            If m_Chr = 255 Then      'Pad a zero byte and advance pointer
                m_Data(m_Ptr + 1) = 0
                m_Ptr = m_Ptr + 2
            Else                     'just advance pointer
                m_Ptr = m_Ptr + 1
            End If
            m_Chr = 0                'clear byte buffer and reset bit index
            m_Bit = 128
        Else                         'increment to next bit position to write
            m_Bit = m_Bit \ 2
        End If
        si = si \ 2
    Wend
End Sub

Private Sub EncodeCoefficients(data() As Integer, p As Long, Pred As Long, Td As Long, Ta As Long)
'Use Huffman tables to compress a block of 64 quantized DCT coefficients to the local
'm_Data() byte array.  The coefficients are input in the data() array starting at index p.
'Pred is the predictor for the DC coefficient.  Td and Ta are indexes to the local DC and AC
'Huffman Tables to use.
    Dim r     As Long
    Dim rs    As Long
    Dim si    As Long
    Dim code  As Long
    Dim p2    As Long

    p2 = p + 64

    code = data(p) - Pred
    Pred = data(p)
    p = p + 1

    si = 1
    rs = 0
    If code < 0 Then
        Do While si <= -code
            si = si * 2
            rs = rs + 1
        Loop
        code = code - 1
    Else
        Do While si <= code
            si = si * 2
            rs = rs + 1
        Loop
    End If
    si = si \ 2
    WriteBits HuffDC(Td).EHUFSI(rs), HuffDC(Td).EHUFCO(rs) 'append symbol for size category
    WriteBits si, code                                     'append diff

    With HuffAC(Ta)
        r = 0
        Do
            If data(p) = 0 Then
                 r = r + 1
            Else
                While r > 15
                    WriteBits .EHUFSI(240), .EHUFCO(240) 'append RUN16 (a run of 16 zeros)
                    r = r - 16
                Wend
                code = data(p)
                rs = r * 16
                si = 1
                If code < 0 Then
                    Do While si <= -code
                        si = si * 2
                        rs = rs + 1
                    Loop
                    code = code - 1
                Else
                    Do While si <= code
                        si = si * 2
                        rs = rs + 1
                    Loop
                End If
                si = si \ 2
                WriteBits .EHUFSI(rs), .EHUFCO(rs) 'append run length, size category
                WriteBits si, code                 'append AC value
                r = 0
            End If
            p = p + 1
        Loop While p < p2 'should be equal on exit
        If r <> 0 Then WriteBits .EHUFSI(0), .EHUFCO(0) 'append EOB (end of block)
    End With

End Sub




'========================================================================================
'                      C O L L E C T I N G   S T A T I S T I C S
'========================================================================================
'These procedures collect statistics of run-length and size categories of DCT coefficients
'so optimized Huffman tables can be generated to compress them.
Private Sub CollectStatisticsAC(data() As Integer, freqac() As Long)
    Dim code As Long
    Dim n    As Long 'Number of coefficients in data()
    Dim p    As Long 'Index for current data() coefficient
    Dim p2   As Long
    Dim r    As Long 'Run length of zeros
    Dim rs   As Long 'Run-length/Size-category Symbol


    n = UBound(data) + 1
    p = 0
    While p <> n
        p = p + 1     'Skip DC coefficient
        p2 = p + 63   '63 AC coefficients

        r = 0
        While p <> p2
            If data(p) = 0 Then
                 r = r + 1
            Else
                While r > 15
                    freqac(240) = freqac(240) + 1  'RUN16 Symbol
                    r = r - 16
                Wend
                code = data(p)
                If code < 0 Then 'rs = number of bits needed for code
                    rs = Int((Log(-code) * 1.442695040889)) + 1   '1/log(2)  (+ error correction)
                ElseIf code > 0 Then
                    rs = Int((Log(code) * 1.442695040889)) + 1    '1/log(2)  (+ error correction)
                Else
                    rs = 0
                End If

                rs = (r * 16) Or rs
                freqac(rs) = freqac(rs) + 1        'Run-length/Size-category Symbol
                r = 0
            End If
            p = p + 1
        Wend
        If r <> 0 Then freqac(0) = freqac(0) + 1   'EOB Symbol
    Wend

End Sub
Private Sub CollectStatisticsDCNonInterleaved(data() As Integer, freqdc() As Long)
    Dim Diff  As Long     'DC Difference
    Dim Pred  As Long     'DC Predictor
    Dim n     As Long     'Number of coefficients in data()
    Dim p     As Long     'Index for current data() coefficient
    Dim s     As Long     'Size category for Diff


    n = UBound(data) + 1
    p = 0
    Pred = 0
    While p <> n
        Diff = data(p) - Pred
        Pred = data(p)

        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
        p = p + 64
    Wend

End Sub
Private Sub CollectStatisticsDCInterleaved(data() As Integer, freqdc() As Long, Hi As Long, Vi As Long)
    Dim p()       As Long     'Index to .data in component f for scanline g
    Dim f         As Long      'Index counter  (component)
    Dim g         As Long      'Index counter  (sampling factor, vertical)
    Dim h         As Long      'Index counter  (sampling factor, horizontal)
    Dim i         As Long      'Index counter  (MCU horizontal)
    Dim j         As Long      'Index counter  (MCU vertical)
    Dim n         As Long      'Number of coefficients in data()
    Dim s         As Long      'Size category for Diff
    Dim Diff      As Long      'DC Difference
    Dim Pred      As Long      'DC Predictor
    Dim pLF       As Long      'Line Feed for p in data
    Dim MCUr      As Long      'Number of complete 8X8 blocks in rightmost MCU
    Dim MCUx      As Long      'Number of MCUs per scanline
    Dim MCUy      As Long      'Number of MCU scanlines


    n = UBound(data) + 1
    ReDim p(Vi - 1)


    MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
    MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)

    h = (-Int(-XX * Hi / HMax) + 7) \ 8  'Width of scanline in data (MCUs)