Ocupa mucho mi imagen página 2

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