cjpeg.cls

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

    Dim MCUx      As Long      'Number of MCUs per scanline
    Dim MCUy      As Long      'Number of MCU scanlines

    Dim p()        As Long     'Index to .data in component f for scanline g
    Dim pLF()      As Long     'Line Feed for p in .data for component f
    Dim Pred()     As Long     'Predictor for DC coefficient in component f
    Dim MCUr()     As Long     'Number of complete 8X8 blocks in rightmost MCU for component f
    Dim Pad64(63)  As Integer  '8X8 padding block for completing MCUs


    Ns = SecondIndex - FirstIndex + 1
    Lx = 6 + 2 * Ns

   'Insert SOS Marker Segment
    m_Data(m_Ptr) = 255                          'SOS Marker
    m_Data(m_Ptr + 1) = SOS
    m_Data(m_Ptr + 2) = Lx \ 256                 'Marker Segment Length
    m_Data(m_Ptr + 3) = Lx And 255
    m_Data(m_Ptr + 4) = Ns                       'Ns     - Number of components in Scan [1-4]
    m_Ptr = m_Ptr + 5
    For i = FirstIndex To SecondIndex
        m_Data(m_Ptr) = Comp(CompIndex(i)).Ci   'Csj
        m_Data(m_Ptr + 1) = Td(i) * 16 Or Ta(i) 'Td, Ta
        m_Ptr = m_Ptr + 2
    Next i
    m_Data(m_Ptr) = 0                            'Ss     - Start of spectral selection
    m_Data(m_Ptr + 1) = 63                       'Se     - End of spectral selection
    m_Data(m_Ptr + 2) = 0                        'Ah, Al - Successive approximation bit high/low
    m_Ptr = m_Ptr + 3


   'Insert interleaved sequential entropy coded data
    ReDim p(FirstIndex To SecondIndex, VMax - 1)
    ReDim Pred(FirstIndex To SecondIndex)
    ReDim pLF(FirstIndex To SecondIndex)
    ReDim MCUr(FirstIndex To SecondIndex)

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

    For f = FirstIndex To SecondIndex
        With Comp(CompIndex(f))
            h = (-Int(-XX * .Hi / HMax) + 7) \ 8  'Width of scanline in .data (MCUs)

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

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

    WriteBitsBegin
    For j = 1 To MCUy - 1

       'Encode MCUs across a scanline
        For i = 1 To MCUx - 1
        For f = FirstIndex To SecondIndex '0 To Ns - 1
        With Comp(CompIndex(f))
        For g = 1 To .Vi
        For h = 1 To .Hi
        EncodeCoefficients .data, p(f, g - 1), Pred(f), Td(f), Ta(f)
        Next h
        Next g
        End With
        Next f
        Next i

       'Encode Rightmost MCU
        For f = FirstIndex To SecondIndex '0 To Ns - 1
        With Comp(CompIndex(f))
        For g = 1 To .Vi
        For h = 1 To .Hi
        If h > MCUr(f) Then 'Pad with dummy block
            Pad64(0) = Pred(f)
            EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
        Else
            EncodeCoefficients .data, p(f, g - 1), Pred(f), Td(f), Ta(f)
        End If
        Next h
        Next g
        End With
        Next f

       'Advance .data pointers
        For f = FirstIndex To SecondIndex
        For g = 0 To Comp(CompIndex(f)).Vi - 1
        p(f, g) = p(f, g) + pLF(f)
        Next g
        Next f
     Next j

   'Encode Bottommost MCU Scanline
    For i = 1 To MCUx
    For f = FirstIndex To SecondIndex
    With Comp(CompIndex(f))
    For g = 1 To .Vi
    For h = 1 To .Hi
    If p(f, g - 1) > UBound(.data) Or (i = MCUx And h > MCUr(f)) Then 'Pad with dummy block
        Pad64(0) = Pred(f)
        EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
    Else
        EncodeCoefficients .data, p(f, g - 1), Pred(f), Td(f), Ta(f)
    End If
    Next h
    Next g
    End With
    Next f
    Next i

    WriteBitsEnd

End Sub

Private Sub InsertSequentialScans(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long)
'Insert scan components CompIndex(FirstIndex) to CompIndex(SecondIndex) sequentially in compliance
'with JPEG rules.  Components are interleaved whenever possible to emit as few scans as possible.

    Dim f            As Long       'First Index
    Dim g            As Long       'Second Index
    Dim Nb           As Long       'Number of 8X8 blocks in MCU
    Const MaxNb      As Long = 10  'Max 8X8 blocks in MCU  (10 for JPEG compliance)
    Dim flag         As Boolean    'True when ready to insert scan(s)

    f = FirstIndex
    g = FirstIndex
    Nb = 0
    flag = False
    While f <= SecondIndex

        Nb = Nb + Comp(CompIndex(g)).Hi * Comp(CompIndex(g)).Vi
        g = g + 1

        If Nb > MaxNb Then
            flag = True
            If f <> g - 1 Then g = g - 1
        Else
            If (g - f) = 3 Or g > SecondIndex Then flag = True
        End If

        If flag Then
            If f = g - 1 Then
                InsertSOSNonInterleaved CompIndex(f), Td(f), Ta(f)
            Else
                InsertSOSInterleaved CompIndex, Td, Ta, f, g - 1
            End If
            Nb = 0
            f = g
            flag = False
        End If
    Wend

End Sub





'========================================================================================
'                               W R I T I N G   F I L E
'========================================================================================
Private Function OptimizeHuffmanTables(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long) As Long
'Optimize Huffman tables for the component indexes given.
'Returns an estimate of the number of bytes needed for entropy coded data.
'Estimate assumes a single scan, and entropy coded FF bytes are not followed by a zero stuff byte.

    Dim f            As Long      'First Index
    Dim g            As Long      'Second Index
    Dim i            As Long
    Dim j            As Long
    Dim k            As Long      'Total bytes required for entropy coded data
    Dim k1           As Long
    Dim k2           As Long
    Dim Nb           As Long      'Number of 8X8 blocks in MCU
    Const MaxNb      As Long = 10 'Max 8X8 blocks in MCU  (10 for JPEG compliance)
    Dim freq(256)    As Long      'frequency count for optimizing Huffman tables
    Dim freq2()      As Long      'copy of freq, used for calcultating entropy coded data size
    Dim IsInter()    As Boolean   'True if component i will be interleaved
    Dim TdUsed()     As Boolean   'True if HuffDC(i) is used
    Dim TaUsed()     As Boolean   'True if HuffAC(i) is used
    Dim flag         As Boolean   'True when ready to include scan(s)

    ReDim IsInter(FirstIndex To SecondIndex)
    ReDim TaUsed(3)
    ReDim TdUsed(3)


   'Determine which components will be interleaved by InsertSequentialScans(), which tables are used
    f = FirstIndex
    g = FirstIndex
    Nb = 0
    flag = False
    While f <= SecondIndex

        Nb = Nb + Comp(CompIndex(g)).Hi * Comp(CompIndex(g)).Vi
        g = g + 1

        If Nb > MaxNb Then
            flag = True
            If f <> g - 1 Then g = g - 1
        Else
            If (g - f) = 3 Or g > SecondIndex Then flag = True
        End If

        If flag Then
            If f = g - 1 Then
                    TdUsed(Td(f)) = True
                    TaUsed(Ta(f)) = True
                    IsInter(f) = False
            Else
                For i = f To g - 1
                    TdUsed(Td(i)) = True
                    TaUsed(Ta(i)) = True
                    IsInter(i) = True
                Next i
            End If
            Nb = 0
            f = g
            flag = False
        End If
    Wend


   'Optimize huffman tables for the scan sequence
    For i = 0 To 3
        If TdUsed(i) Then
            For f = FirstIndex To SecondIndex
                With Comp(CompIndex(f))
                    If Td(f) = i Then
                        If IsInter(f) Then
                            CollectStatisticsDCInterleaved .data, freq, .Hi, .Vi
                        Else
                            CollectStatisticsDCNonInterleaved .data, freq
                        End If
                    End If
                End With
            Next f

           'Optimize and create this DC table
            freq2 = freq
            OptimizeHuffman HuffDC(i), freq
            ExpandHuffman HuffDC(i), IIf(PP = 12, 15, 11)

           'Calculate compressed data size and add to total k
            For j = 0 To 15
                If freq2(j) <> 0 Then
                    k1 = j + Int(Log(HuffDC(i).EHUFSI(j)) * 1.442695040889) + 1 'Length of size category, in bits
                    k2 = k2 + freq2(j) * k1                                     'Sum all occurances of this coefficient, in bits
                    k = k + k2 \ 8                                              'add to byte count
                    k2 = k2 Mod 8                                               'preserve remaining bits
                End If
            Next j

        End If
        If TaUsed(i) Then
            For f = FirstIndex To SecondIndex
                If Td(f) = i Then CollectStatisticsAC Comp(CompIndex(f)).data, freq
            Next f

           'Optimize and create this AC table
            freq2 = freq
            OptimizeHuffman HuffAC(i), freq
            ExpandHuffman HuffAC(i), 255

           'Calculate compressed data size and add to total k
            For j = 0 To 255
                If freq2(j) <> 0 Then
                    k1 = (j And 15) + Int(Log(HuffAC(i).EHUFSI(j)) * 1.442695040889) + 1 'Length of size category, in bits
                    k2 = k2 + freq2(j) * k1                                              'Sum all occurances of this coefficient, in bits
                    k = k + k2 \ 8                                                       'add to byte count
                    k2 = k2 Mod 8                                                        'preserve remaining bits
                End If
            Next j

        End If
    Next i

    If (k2 Mod 8) <> 0 Then k = k + 1
    OptimizeHuffmanTables = k

End Function



Public Function SaveFile(FileName As String) As Long
    Dim CompIndex()  As Long 'Indexes of Components to be included
    Dim Td()         As Long 'DC Huffman Table Selectors
    Dim Ta()         As Long 'AC Huffman Table Selectors
    Dim FileNum      As Integer
    Dim i            As Long


    If Len(FileName) = 0 Then
        SaveFile = 1         'FileName not given
    Else
        If (Len(Dir(FileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive)) > 0) Then
            SaveFile = 2     'File already exists
        Else


    ReDim CompIndex(Nf - 1)
    ReDim Td(Nf - 1)
    ReDim Ta(Nf - 1)

    For i = 0 To Nf - 1
        CompIndex(i) = i
        Td(i) = IIf(i = 0, 0, 1)
        Ta(i) = IIf(i = 0, 0, 1)
    Next i

    i = OptimizeHuffmanTables(CompIndex, Td, Ta, 0, Nf - 1)

   'Estimate maximum possible file size needed
    i = 1.3 * i + 1000 + Len(m_Comment)
    ReDim m_Data(i)
    m_Ptr = 0

    InsertMarker SOI                                   'SOI - Start of Image
    InsertJFIF                                         'JFIF

    If Len(m_Comment) > 0 Then InsertCOM m_Comment     'COM