Ocupa mucho mi imagen

[ranslsad]

como la paso la renombro y creo que me ocupa lo mismo

ranslsad no creo k eso le sirva por k creo k lo k el kiere es hacer un troyano y k capture la imagen la pase a jpg y la pase x winsock al cliente todo de forma oculta 

Si ya veo que yo iba un poco perdido...

Bueno espero que encuentres lo que buscas XD

Salu2

Ranslsad

[sircid]

la dll cjpge y un ejemplo de como utilizarla está en mi post de arriba.

[David Vans]

Gracias a todos ya he consigo arreglar el problema he consegido reducir 3.75 Mb a 188 Kb con esta maravilla de clase.
[code]
Option Explicit
Option Base 0

'Class Name:   cJpeg.cls  "JPEG Encoder Class"
'Author:       John Korejwa  <korejwa@tiac.net>
'Version:      0.9 beta  [26 / November / 2003]
'
'
'Legal:
'        This class is intended for and was uploaded to www.planetsourcecode.com
'
'        This product includes JPEG compression code developed by John Korejwa.  <korejwa@tiac.net>
'        Source code, written in Visual Basic, is freely available for non-commercial,
'        non-profit use at www.planetsourcecode.com.
'
'
'Credits:
'        Special thanks to Barry G., a government research scientist who took an interest in my
'        steganography software and research in late 1999.  I never met Barry in person, but he
'        was kind enough to buy and mail me a book with the ISO DIS 10918-1 JPEG standard.
'
'
'Description:  This class contains code for compressing pictures, sampled via hDC, into
'              baseline .JPG files.  Please report any errors or unusual behavior to the email
'              address above.
'
'Dependencies: None
'


'JPEG Marker Constants                (Note: VB compiler does not compile unused constants)
                                      'Non-Differential Huffman Coding
Private Const SOF0    As Long = &HC0& 'Baseline DCT
Private Const SOF1    As Long = &HC1& 'Extended sequential DCT
Private Const SOF2    As Long = &HC2& 'Progressive DCT
Private Const SOF3    As Long = &HC3& 'Spatial (sequential) lossless
                                      'Differential Huffman coding
Private Const SOF5    As Long = &HC5& 'Differential sequential DCT
Private Const SOF6    As Long = &HC6& 'Differential progressive DCT
Private Const SOF7    As Long = &HC7& 'Differential spatial
                                      'Non-Differential arithmetic coding
Private Const JPG     As Long = &HC8& 'Reserved for JPEG extentions
Private Const SOF9    As Long = &HC9& 'Extended sequential DCT
Private Const SOF10   As Long = &HCA& 'Progressive DCT
Private Const SOF11   As Long = &HCB& 'Spatial (sequential) lossless
                                      'Differential arithmetic coding
Private Const SOF13   As Long = &HCD& 'Differential sequential DCT
Private Const SOF14   As Long = &HCE& 'Differential progressive DCT
Private Const SOF15   As Long = &HCF& 'Differential Spatial
                                      'Other Markers
Private Const DHT     As Long = &HC4& 'Define Huffman tables
Private Const DAC     As Long = &HCC& 'Define arithmetic coding conditioning(s)
Private Const RSTm    As Long = &HD0& 'Restart with modulo 8 count "m"
Private Const RSTm2   As Long = &HD7& 'to 'Restart with modulo 8 count "m"
Private Const SOI     As Long = &HD8& 'Start of image
Private Const EOI     As Long = &HD9& 'End of image
Private Const SOS     As Long = &HDA& 'Start of scan
Private Const DQT     As Long = &HDB& 'Define quantization table(s)
Private Const DNL     As Long = &HDC& 'Define number of lines
Private Const DRI     As Long = &HDD& 'Define restart interval
Private Const DHP     As Long = &HDE& 'Define hierarchical progression
Private Const EXP     As Long = &HDF& 'Expand reference components
Private Const APP0    As Long = &HE0& 'Reserved for application segments
Private Const APPF    As Long = &HEF& '  to Reserved for application segments
Private Const JPGn    As Long = &HF0& 'Reserved for JPEG Extentions
Private Const JPGn2   As Long = &HFD& '  to Reserved for JPEG Extentions
Private Const COM     As Long = &HFE& 'Comment
Private Const RESm    As Long = &H2&  'Reserved
Private Const RESm2   As Long = &HBF& '  to Reserved
Private Const TEM     As Long = &H1&  'For temporary use in arithmetic coding

'Consider these arrays of constants.
'They are initialized with the class and do not change.
Private QLumin(63)    As Integer 'Standard Luminance   Quantum (for 50% quality)
Private QChrom(63)    As Integer 'Standard Chrominance Quantum (for 50% quality)
Private FDCTScale(7)  As Double  'Constants for scaling FDCT Coefficients
Private IDCTScale(7)  As Double  'Constants for scaling IDCT Coefficients
Private ZigZag(7, 7)  As Long    'Zig Zag order of 8X8 block of samples

'API constants
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 DIB_RGB_COLORS  As Long = 0


'Variable types needed for DIBSections.
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 BITMAPINFO
    bmiHeader         As BITMAPINFOHEADER
    bmiColors         As RGBQUAD
End Type

'API needed for creating DIBSections for sampling and pixel access.
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) 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 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 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 Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


'Custom variable types used for this JPEG encoding implementation
Private Type QUANTIZATIONTABLE
    Qk(63)            As Integer 'Quantization Values
    FScale(63)        As Single  'Multiplication values to scale and Quantize   FDCT output
    IScale(63)        As Single  'Multiplication values to scale and DeQuantize IDCT input
End Type
Private Type HUFFMANTABLE
    BITS(15)          As Byte    'Number of huffman codes of length i+1
    HUFFVAL(255)      As Byte    'Huffman symbol values
    EHUFSI(255)       As Long    'Huffman code size for symbol i
    EHUFCO(255)       As Long    'Huffman code      for symbol i
    MINCODE(15)       As Long    '
    MAXCODE(15)       As Long    'Largest code value for length i+1
End Type
Private Type COMPONENT
    Ci                As Long    'Component ID                       [0-255]
    Hi                As Long    'Horizontal Sampling Factor         [1-4]
    Vi                As Long    'Vertical   Sampling Factor         [1-4]
    Tqi               As Long    'Quantization Table Select          [0-3]
    data()            As Integer 'DCT Coefficients
End Type

Private PP            As Long    'Sample Precision [8, 12]
Private YY            As Long    'Number of lines             [Image Height]
Private XX            As Long    'Number of samples per line  [Image Width]
Private Nf            As Long    'Number of components in Frame

Private HMax          As Long    'Maximum horizontal sampling frequency
Private VMax          As Long    'Maximum vertical   sampling frequency

Private m_Data()      As Byte    'JPEG File Data
Private m_Chr         As Long    'Current Character in m_Data
Private m_Ptr         As Long    'Byte index in m_Data
Private m_Bit         As Long    'Bit  index in m_Chr

Private m_Block(7, 7) As Single  'Buffer for calculating DCT

Private QTable(3)     As QUANTIZATIONTABLE  '4 Quantization Tables
Private HuffDC(3)     As HUFFMANTABLE       '4 DC Huffman Tables
Private HuffAC(3)     As HUFFMANTABLE       '4 AC Huffman Tables
Private Comp()        As COMPONENT          'Scan Components

Private m_Quality     As Long
Private m_Comment     As String



'========================================================================================
'              D I S C R E T E   C O S I N E   T R A N S F O R M A T I O N
'========================================================================================
Private Sub FDCT()
    Static t0   As Single 'Given an 8X8 block of discretely sampled values [m_Block(0-7, 0-7)],
    Static t1   As Single 'replace them with their (scaled) Forward Discrete Cosine Transformation values.
    Static t2   As Single '80 (+64) multiplications and 464 additions are needed.
    Static t3   As Single 'Values are scaled on output, meaning that each of the 64 elements must be
    Static t4   As Single 'multiplied by constants for a final FDCT.  These final constants are combined
    Static t5   As Single 'with Quantization constants, so a final 64 multiplications combine the
    Static t6   As Single 'completion of the FDCT and Quantization in one step.
    Static t7   As Single
    Static t8   As Single
    Static i    As Long

    For i = 0 To 7                  'Process 1D FDCT on each row
        t0 = m_Block(i, 0) + m_Block(i, 7)
        t1 = m_Block(i, 0) - m_Block(i, 7)
        t2 = m_Block(i, 1) + m_Block(i, 6)
        t3 = m_Block(i, 1) - m_Block(i, 6)
        t4 = m_Block(i, 2) + m_Block(i, 5)
        t5 = m_Block(i, 2) - m_Block(i, 5)
        t6 = m_Block(i, 3) + m_Block(i, 4)
        t7 = m_Block(i, 3) - m_Block(i, 4)

        t7 = t7 + t5
        t8 = t0 - t6
        t6 = t6 + t0
        t0 = t2 + t4
        t2 = (t2 - t4 + t8) * 0.707106781186548   'Cos(2# * PI / 8#)
        t4 = t1 + t3
        t3 = (t3 + t5) * 0.707106781186548        'Cos(2# * PI / 8#)
        t5 = (t4 - t7) * 0.382683432365091        'Cos(3# * PI / 8#)
        t7 = t7 * 0.541196100146196 - t5          'Cos(PI / 8#) - Cos(3# * PI / 8#)
        t4 = t4 * 1.30656296487638 - t5           'Cos(PI / 8#) + Cos(3# * PI / 8#)
        t5 = t1 + t3
        t1 = t1 - t3

        m_Block(i, 0) = t6 + t0
        m_Block(i, 4) = t6 - t0
        m_Block(i, 1) = t5 + t4
        m_Block(i, 7) = t5 - t4
        m_Block(i, 2) = t8 + t2
        m_Block(i, 6) = t8 - t2
        m_Block(i, 5) = t1 + t7
        m_Block(i, 3) = t1 - t7
    Next i

    For i = 0 To 7                   'Process 1D FDCT on each column
        t0 = m_Block(0, i) + m_Block(7, i)
        t1 = m_Block(0, i) - m_Block(7, i)
        t2 = m_Block(1, i) + m_Block(6, i)
        t3 = m_Block(1, i) - m_Block(6, i)
        t4 = m_Block(2, i) + m_Block(5, i)
        t5 = m_Block(2, i) - m_Block(5, i)
        t6 = m_Block(3, i) + m_Block(4, i)
        t7 = m_Block(3, i) - m_Block(4, i)

        t7 = t7 + t5
        t8 = t0 - t6
        t6 = t6 + t0
        t0 = t2 + t4
        t2 = (t2 - t4 + t8) * 0.707106781186548   'Cos(2# * PI / 8#)
        t4 = t1 + t3
        t3 = (t3 + t5) * 0.707106781186548        'Cos(2# * PI / 8#)
        t5 = (t4 - t7) * 0.382683432365091        'Cos(3# * PI / 8#)
        t7 = t7 * 0.541196100146196 - t5          'Cos(PI / 8#) - Cos(3# * PI / 8#)
        t4 = t4 * 1.30656296487638 - t5           'Cos(PI / 8#) + Cos(3# * PI / 8#)
        t5 = t1 + t3
        t1 = t1 - t3

        m_Block(0, i) = t6 + t0
        m_Block(4, i) = t6 - t0
        m_Block(1, i) = t5 + t4
        m_Block(7, i) = t5 - t4
        m_Block(2, i) = t8 + t2
        m_Block(6, i) = t8 - t2
        m_Block(5, i) = t1 + t7
        m_Block(3, i) = t1 - t7
    Next i
End Sub




'================================================================================
'                 H U F F M A N   T A B L E   G E N E R A T I O N
'================================================================================
Private Sub OptimizeHuffman(TheHuff As HUFFMANTABLE, freq() As Long)
'Generate optimized values for BITS and HUFFVAL in a HUFFMANTABLE
'based on symbol frequency counts.  freq must be dimensioned freq(0-256)
'and contain counts of symbols 0-255.  freq is destroyed in this procedure.
    Dim i              As Long
    Dim j              As Long
    Dim k              As Long
    Dim n              As Long
    Dim V1             As Long
    Dim V2             As Long
    Dim others(256)    As Long
    Dim codesize(256)  As Long
    Dim BITS(256)      As Long
    Dim swp            As Long
    Dim swp2           As Long


    For i = 0 To 256  'Initialize others to -1, (this value terminates chain of indicies)
        others(i) = -1
    Next i
    freq(256) = 1     'Add dummy symbol to guarantee no code will be all '1' bits

   'Generate codesize()   [find huffman code sizes]
    Do 'do loop for (#non-zero-frequencies - 1) times
        V1 = -1                            'find highest v1 for      least value of freq(v1)>0
        V2 = -1                            'find highest v2 for next least value of freq(v2)>0
        swp = 2147483647 'Max Long variable
        swp2 = 2147483647
        For i = 0 To 256
            If freq(i) <> 0 Then
                If (freq(i) <= swp2) Then
                    If (freq(i) <= swp) Then
                        swp2 = swp
                        V2 = V1
                        swp = freq(i)
                        V1 = i
                    Else
                        swp2 = freq(i)
                        V2 = i
                    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
    'h = h \ 8                            'Width of scanline in data (MCUs)

    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
    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
    m_Data(m_Ptr + 3) = 8 And 255
    m_Data(m_Ptr + 4) = 1                        'Ns     - Number of components in Scan [1-4]
    m_Ptr = m_Ptr + 5
    m_Data(m_Ptr) = Comp(CompIndex).Ci           'Csj    - Component ID
    m_Data(m_Ptr + 1) = Td * 16 Or Ta            'Td, Ta - DC, AC entropy coder selector
    m_Ptr = m_Ptr + 2
    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 non-interleaved sequential entropy coded data
    With Comp(CompIndex)

        p = 0
        n = UBound(.data) + 1
        Pred = 0

        WriteBitsBegin
        While p <> n
            EncodeCoefficients .data, p, Pred, Td, Ta
        Wend
        WriteBitsEnd

    End With

End Sub

Private Sub InsertSOSInterleaved(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long)
'Insert an SOS marker and scan data for an interleaved Sequential scan.

    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 Lx        As Long      'Marker Segment Length
    Dim Ns        As Long      'Number of components in Scan [1-4]
    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

[Meg]

muy bien pues ya sabes a seguir programando k es divetido  ,ya veras como teminas tu toyano