Tweet
'------------------------------------------------------------------------------------
' PBJPEG.BAS - PowerBasic JPEG Encoder
'------------------------------------------------------------------------------------
'
#If Not %DEF(%WINAPI)
#Include "win32api.inc" 'add win32api if not already added
#ENDIF
%NOMSG = 0 'Change to 0 to display error messages for debuging or 1 to not show messages
'------------------------------------------------------------------------------------
' JPEG Marker Constants
'------------------------------------------------------------------------------------
' Non-Differential Huffman Coding
%SOF0 = &HC0& ' Baseline DCT
%SOF1 = &HC1& ' Extended sequential DCT
%SOF2 = &HC2& ' Progressive DCT
%SOF3 = &HC3& ' Spatial (sequential) lossless
' Differential Huffman coding
%SOF5 = &HC5& ' Differential sequential DCT
%SOF6 = &HC6& ' Differential progressive DCT
%SOF7 = &HC7& ' Differential spatial
' Non-Differential arithmetic coding
%JPG = &HC8& ' Reserved for JPEG extentions
%SOF9 = &HC9& ' Extended sequential DCT
%SOF10 = &HCA& ' Progressive DCT
%SOF11 = &HCB& ' Spatial (sequential) lossless
' Differential arithmetic coding
%SOF13 = &HCD& ' Differential sequential DCT
%SOF14 = &HCE& ' Differential progressive DCT
%SOF15 = &HCF& ' Differential Spatial
' Other Markers
%DHT = &HC4& ' Define Huffman tables
%DAC = &HCC& ' Define arithmetic coding conditioning(s)
%RSTM = &HD0& ' Restart with modulo 8 count "m"
%RSTM2 = &HD7& ' to Restart with modulo 8 count "m"
%SOI = &HD8& ' Start of image
%EOI = &HD9& ' End of image
%SOS = &HDA& ' Start of scan
%DQT = &HDB& ' Define quantization table(s)
%DNL = &HDC& ' Define number of lines
%DRI = &HDD& ' Define restart interval
%DHP = &HDE& ' Define hierarchical progression
%VEXP = &HDF& ' Expand reference components
%APP0 = &HE0& ' Reserved for application segments
%APPF = &HEF& ' to Reserved for application segments
%JPGN = &HF0& ' Reserved for JPEG Extentions
%JPGN2 = &HFD& ' to Reserved for JPEG Extentions
%COM = &HFE& ' Comment
%RESM = &H2& ' Reserved
%RESM2 = &HBF& ' to Reserved
%TEM = &H1& ' For temporary use in arithmetic coding
%TWOE00 = &H1&
%TWOE01 = &H2&
%TWOE02 = &H4&
%TWOE03 = &H8&
%TWOE04 = &H10&
%TWOE05 = &H20&
%TWOE06 = &H40&
%TWOE07 = &H80&
%TWOE08 = &H100&
%TWOE09 = &H200&
%TWOE10 = &H400&
%TWOE11 = &H800&
%TWOE12 = &H1000&
%TWOE13 = &H2000&
%TWOE14 = &H4000&
%TWOE15 = &H8000&
' Consider these arrays of constants.
' They are initialized with the module and do not change.
Global g_QLumin() As Byte ' Standard Luminance Quantum (for 50% quality)
Global g_QChrom() As Byte ' Standard Chrominance Quantum (for 50% quality)
Global g_TwoP() As Long ' Powers of two 2^P
Global g_TwoR() As Long ' Powers of two 2^(R-1)
Global g_TwoB() As Byte ' The number of bits in value
Global g_EIDCTScale() As Long ' Encoding Constants for scaling IntDCT Coefficients
Global g_DIDCTScale() As Long ' Decoding Constants for scaling IntDCT Coefficients
Global g_ZigZag() As Long ' Zig Zag order of 8X8 block of samples
' Custom variable types used for this JPEG encoding implementation
Type QUANTIZATIONTABLE
Qk(63) As Integer ' Quantization Values
FScale(63) As Long ' Multiplication values to scale and Quantize FDCT output
IScale(63) As Long ' Multiplication values to scale and DeQuantize IDCT input
End Type
Type HUFFMANTABLE
vBits(15) As Byte ' Number of huffman codes of length i+1
HuffVal(255) As Byte ' Huffman symbol values
EHufLN(255) As Byte ' Huffman codelength in Bits for symbol i
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
Type vComponent
Ci As Long ' Component ID [0-255]
vHi As Long ' Horizontal Sampling Factor [1-4]
Vi As Long ' Vertical Sampling Factor [1-4]
Tqi As Long ' Quantization Table Select [0-3]
ptrData As Integer Ptr ' A dirty workaround to the PB UDT dynamic array issue
End Type
'------------------------------------------------------------------------------------
' Global variables
'------------------------------------------------------------------------------------
Global g_PP As Long ' Sample Precision [8, 12]
Global g_YY As Long ' Number of lines [Image Height] after clipping
Global g_XX As Long ' Number of samples per line [Image Width] after clipping
Global g_Nf As Long ' Number of components in Frame
Global g_HMax As Long ' Maximum horizontal sampling frequency
Global g_VMax As Long ' Maximum vertical sampling frequency
Global g_m_Data() As Byte ' JPEG File Data
Global g_m_Chr As Long ' Current Character in g_m_Data
Global g_m_Ptr As Long ' Byte index in g_m_Data
Global g_m_Bit As Long ' Bit index in g_m_Chr
Global g_m_Block() As Long ' Buffer for calculating intDCT (7,7)
Global g_QTable() As QUANTIZATIONTABLE ' 4 Quantization Tables
Global g_HuffDC() As HUFFMANTABLE ' 4 DC Huffman Tables
Global g_HuffAC() As HUFFMANTABLE ' 4 AC Huffman Tables
Global g_Comp() As vComponent ' Scan Components
Global g_CompData0() As Integer ' DCT Coefficients [DC(0),AC(1-63)]*nBlocks
Global g_CompData1() As Integer
Global g_CompData2() As Integer
Global g_m_Quality As Long
Global g_m_Comment As String
'------------------------------------------------------------------------------------
' Function prototypes
'------------------------------------------------------------------------------------
Declare Function piaUBOUND(ByRef iArray() As Integer) As Long
Declare Sub piaREDIM(ByRef iArray() As Integer, ByVal lValue As Long)
Declare Sub piaREDIMPRESERVE(ByRef iArray() As Integer, ByVal lValue As Long)
Declare Sub piaSET(ByRef iArray() As Integer, ByVal lNdx As Long, ByVal sValue As Integer)
Declare Function piaGET(ByRef iArray() As Integer, ByVal lNdx As Long) As Integer
Declare Sub intDCT()
Declare Sub TransformAndQuantize(ByRef vPixel() As Byte, ByVal CompIndex As Long, ByRef FScale() As Long, _
ByVal vWidth As Long, ByVal Height As Long, ByVal RowMod As Long)
Declare Function PBJPEG_SetQuality(ByVal vQuality As Long) As Long
Declare Sub ExpandDQT(ByVal Tqi As Long)
Declare Sub BuildHuffman(ByRef TheHuff As HUFFMANTABLE, ByRef Freq() As Long)
Declare Sub ExpandHuffman(ByRef TheHuff As HUFFMANTABLE, ByVal MaxSymbol As Long)
Declare Function CodeLength(ByRef TheHuff As HUFFMANTABLE, ByRef Freq() As Long) As Long
Declare Sub WriteBitsBegin()
Declare Sub WriteBitsEnd()
Declare Sub WriteBits(ByVal mask As Long, ByVal code As Long)
Declare Sub EncodeCoefficients(ByRef vData() As Integer, ByRef p As Long, ByRef Pred As Long, _
ByVal Td As Long, ByVal Ta As Long)
Declare Sub CollectStatisticsAC(ByRef vData() As Integer, ByRef FreqAC() As Long)
Declare Sub CollectStatisticsDCNonInterleaved(ByRef vData() As Integer, ByRef FreqDC() As Long)
Declare Sub CollectStatisticsDCInterleaved(ByRef vData() As Integer, ByRef FreqDC() As Long, _
ByVal vHi As Long, ByVal Vi As Long)
Declare Sub PBJPEG_SetSamplingFrequencies(ByVal H1 As Long, ByVal v1 As Long, _
ByVal H2 As Long, ByVal v2 As Long, _
ByVal H3 As Long, ByVal v3 As Long)
Declare Function PBJPEG_SampleHDC(ByVal lHDC As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lSrcLeft As Long, _
ByVal lSrcTop As Long) As Long
Declare Function PBJPEG_AddComment(ByVal vComment As String) As Long
Declare Sub InsertJFIF()
Declare Sub InsertSOF(ByVal SOFMarker As Long)
Declare Sub InsertCOM(ByVal TheComment As String)
Declare Sub InsertDQT(ByVal MarkerPos As Long, ByVal Tqi As Long)
Declare Sub InsertDHT(ByVal MarkerPos As Long, ByVal HIndex As Long, ByVal isAC As Long)
Declare Sub InsertMarker(ByVal TheMarker As Long)
Declare Sub InsertSOSNonInterleaved(ByVal CompIndex As Long, ByVal Td As Long, ByVal Ta As Long)
Declare Sub InsertSOSInterleaved(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long)
Declare Sub InsertSequentialScans(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long)
Declare Function OptimizeHuffmanTables(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long) As Long
Declare Function PBJPEG_SaveFile(FileName As String) As Long
Declare Function PBJPEG_Initialize() As Long
Declare Sub Init_BitMasks()
Declare Sub GenEIDCT()
Declare Function nBits(ByVal v As Long) As Long
'------------------------------------------------------------------------------------
' Pointer-based handling of Integer arrays
'------------------------------------------------------------------------------------
' Based on the work of Stan Durham
Function piaUBOUND(ByRef iArray() As Integer) As Long
Function = UBound(iArray())
End Function
'------------------------------------------------------------------------------------
Sub piaREDIM(ByRef iArray() As Integer, ByVal lValue As Long)
ReDim iArray(lValue)
End Sub
'------------------------------------------------------------------------------------
Sub piaREDIMPRESERVE(ByRef iArray() As Integer, ByVal lValue As Long)
ReDim Preserve iArray(lValue)
End Sub
'------------------------------------------------------------------------------------
Sub piaSET(ByRef iArray() As Integer, ByVal lNdx As Long, ByVal sValue As Integer)
iArray(lNdx) = sValue
End Sub
'------------------------------------------------------------------------------------
Function piaGET(ByRef iArray() As Integer, ByVal lNdx As Long) As Integer
Function = iArray(lNdx)
End Function
'------------------------------------------------------------------------------------
' Integer discrete cosine transformation
'------------------------------------------------------------------------------------
Sub intDCT()
Try
' Integer Lifted, Loeffler factorisation 22 shifts, 40 adds by Jie Liang, Trac Tran
' See IEEE TRANSACTIONS ON SIGNAL PROCESSING VOL49, #12 DEC 2001
' This is carefully optimized and its easy to screw its performance up
' However its ideally suited to asm, so go for it Vlad!
Local t0 As Long, t1 As Long, t2 As Long, t3 As Long
Local t4 As Long, t5 As Long, t6 As Long, t7 As Long
Local t8 As Long, t9 As Long, t10 As Long, t11 As Long
Local i As Long
For i = 0 To 7 ' Process 1D intDCT on each row
t0 = g_m_Block(i, 0)
t8 = g_m_Block(i, 7)
t7 = t0 - t8
t0 = t0 + t8
t1 = g_m_Block(i, 1)
t8 = g_m_Block(i, 6)
t6 = t1 - t8
t1 = t1 + t8
t2 = g_m_Block(i, 2)
t8 = g_m_Block(i, 5)
t5 = t2 - t8
t2 = t2 + t8
t3 = g_m_Block(i, 3)
t8 = g_m_Block(i, 4)
t4 = t3 - t8
t3 = t3 + t8
' Top half
t8 = t0 + t3
t9 = t1 + t2
t8 = t8 + t9
g_m_Block(i, 0) = t8
g_m_Block(i, 4) = t8 \ 2 - t9 ' 1/2 *t8
t10 = t1 - t2
t11 = t0 - t3
t10 = (t11 \ 4 + t11 \ 8 + t11 \ 32) - t10 ' 13/32*t11
g_m_Block(i, 6) = t10
g_m_Block(i, 2) = t11 - (t10 \ 4 + t10 \ 16 + t10 \ 32) ' -11/32*t10
' Bottom half
t7 = t7 - (t4 \ 4 + t4 \ 32 + t4 \ 64) ' -19/64*t4
t4 = t4 + (t7 \ 2 + t7 \ 16) ' + 9/16*t7
t7 = t7 - (t4 \ 4 + t4 \ 32 + t4 \ 64) ' -19/64*t4
t6 = t6 - (t5 \ 16 + t5 \ 32) ' - 3/32*t5
t5 = t5 + (t6 \ 8 + t6 \ 16) ' + 3/16*t6
t6 = t6 - (t5 \ 16 + t5 \ 32) ' - 3/32*t5
g_m_Block(i, 3) = t7 - t5
g_m_Block(i, 5) = t4 - t6
t8 = t4 + t6
t11 = t5 + t7 + t8
g_m_Block(i, 1) = t11
g_m_Block(i, 7) = t11 \ 2 - t8 ' 1/2
Next i
For i = 0 To 7 ' Process 1D intDCT on each column
t0 = g_m_Block(0, i)
t8 = g_m_Block(7, i)
t7 = t0 - t8
t0 = t0 + t8
t1 = g_m_Block(1, i)
t8 = g_m_Block(6, i)
t6 = t1 - t8
t1 = t1 + t8
t2 = g_m_Block(2, i)
t8 = g_m_Block(5, i)
t5 = t2 - t8
t2 = t2 + t8
t3 = g_m_Block(3, i)
t8 = g_m_Block(4, i)
t4 = t3 - t8
t3 = t3 + t8
' Top half
t8 = t0 + t3
t9 = t1 + t2
t8 = t8 + t9
g_m_Block(0, i) = t8
g_m_Block(4, i) = t8 \ 2 - t9 ' 1/2 *t8
t10 = t1 - t2
t11 = t0 - t3
t10 = (t11 \ 4 + t11 \ 8 + t11 \ 32) - t10 ' 13/32*t11
g_m_Block(6, i) = t10
g_m_Block(2, i) = t11 - (t10 \ 4 + t10 \ 16 + t10 \ 32) ' -11/32*t10
' Bottom half
t7 = t7 - (t4 \ 4 + t4 \ 32 + t4 \ 64) ' -19/64*t4
t4 = t4 + (t7 \ 2 + t7 \ 16) ' + 9/16*t7
t7 = t7 - (t4 \ 4 + t4 \ 32 + t4 \ 64) ' -19/64*t4
t6 = t6 - (t5 \ 16 + t5 \ 32) ' - 3/32*t5
t5 = t5 + (t6 \ 8 + t6 \ 16) ' + 3/16*t6
t6 = t6 - (t5 \ 16 + t5 \ 32) ' - 3/32*t5
g_m_Block(3, i) = t7 - t5
g_m_Block(5, i) = t4 - t6
t8 = t4 + t6
t11 = t5 + t7 + t8
g_m_Block(1, i) = t11
g_m_Block(7, i) = t11 \ 2 - t8 ' 1/2
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error1",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Quantization
'------------------------------------------------------------------------------------
Sub TransformAndQuantize(ByRef vPixel() As Byte, ByVal CompIndex As Long, ByRef FScale() As Long, _
ByVal vWidth As Long, ByVal Height As Long, ByVal RowMod As Long)
Try
Local i As Long ' Pixel Index (Horizontal)
Local j As Long ' Pixel Index (Vertical)
Local k As Long ' Index of an 8X8 block of pixels
Local p As Long ' DCT Index (horizontal)
Local q As Long ' DCT Index (vertical)
Local t As Long ' COMPONENT in Zig Zag order at index BlkPtr
Local n As Long ' Size of Image
Local BlkPtr As Long ' Index for quantized intDCT value (in component data)
Local BlkMod As Long ' StepWidth for a Block
Local RowModS As Long ' Length of a Sample Row
Local BlkModS As Long ' Length of a Sample Row of Blocks
Local fr As Long
Local fg As Long
Local fb As Long
Local fc As Long
Select Case CompIndex
Case 0 ' Luminance rm = 0.299; gm = 0.587; bm = 0.114; s = 128
fr = 19595&: fg = 38470: fb = 7471&: fc = 8388608
Case 1 ' Chrominance [Blue-Yellow] rm = -0.16874; gm = -0.33126; bm = 0.5; s = 0
fr = -11059&: fg = -21709&: fb = 32768: fc = 0
Case 2 ' Chrominance [Red-Green] rm = 0.5; gm = -0.41869; bm = -0.08131; s=0
fr = 32768: fg = -27439&: fb = -5329&: fc = 0
End Select
'REDIM g_Comp(CompIndex).vData(vWidth * Height - 1)
piaREDIM ByVal g_Comp(CompIndex).ptrData, vWidth * Height - 1
' Reset output Quantized intDCT Coefficient Index
BlkPtr = 0
n = Height * RowMod
RowModS = vWidth * 3
BlkMod = RowMod - 24
BlkModS = 8 * RowMod - RowModS
i = 0
Do While i < n
k = RowModS
Do
j = i
' Get 8X8 block of level shifted YCbCr values
For q = 0 To 7
For p = 0 To 7
g_m_Block(p, q) = fr * vPixel(i + 2) + fg * vPixel(i + 1) + fb * vPixel(i) - fc
i = i + 3
Next p
i = i + BlkMod
Next q
' Take 8X8 block of unscaled DCT coefficients [g_m_Block(0-7, 0-7)],
' Scale, Quantize, and store the results in data() array of
' COMPONENT in Zig Zag order at index BlkPtr
' Calculate the integer DCT (it is scaled by 65536)
Call intDCT
For q = 0 To 7
For p = 0 To 7
t = g_ZigZag(p, q)
' g_Comp(CompIndex).vData(BlkPtr + t) = (((g_m_Block(p, q) + 16384&) \ 32768) * _
' FScale(t) + 131072) \ 262144
' Keep 1 decimal bit
piaSET ByVal g_Comp(CompIndex).ptrData, BlkPtr + t, (((g_m_Block(p, q) + 16384&) \ 32768) * _
FScale(t) + 131072) \ 262144
' 2* true scale 4*scale
Next p
Next q
BlkPtr = BlkPtr + 64
i = j + 24
' Start Next Block this Row
k = k - 24
Loop Until k = 0
i = i + BlkModS
Loop
Catch
If %NOMSG = 0 Then MsgBox "JPG Error2",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Image quality adjustment
'------------------------------------------------------------------------------------
Function PBJPEG_SetQuality(ByVal vQuality As Long) As Long
Try
' 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.
Local i As Long
Local qvalue As Long
Local maxvalue As Long
Local scalefactor As Long
If g_PP = 12 Then
maxvalue = 65535
Else
maxvalue = 255
End If
If vQuality > 0 And vQuality <= 100 Then
g_m_Quality = vQuality
Else
g_m_Quality = 75 ' Else default 75
End If
If (g_m_Quality < 50) Then
If g_m_Quality = 0 Then
scalefactor = 5000
Else
scalefactor = 5000 \ g_m_Quality
End If
Else
If g_m_Quality >= 100 Then
scalefactor = 0
Else
scalefactor = 200 - g_m_Quality * 2
End If
End If
For i = 0 To 63
qvalue = (g_QLumin(i) * scalefactor + 50) \ 100
If qvalue <= 0 Then
qvalue = 1
ElseIf qvalue > maxvalue Then
qvalue = maxvalue
End If
g_QTable(0).Qk(i) = qvalue
Next i
For i = 0 To 63
qvalue = (g_QChrom(i) * scalefactor + 50) \ 100
If qvalue <= 0 Then
qvalue = 1
ElseIf qvalue > maxvalue Then
qvalue = maxvalue
End If
g_QTable(1).Qk(i) = qvalue
Next i
ExpandDQT 0
ExpandDQT 1
Catch
If %NOMSG = 0 Then MsgBox "JPG Error3",,Error$(Err)
End Try
End Function
'------------------------------------------------------------------------------------
Sub ExpandDQT(ByVal Tqi As Long)
Try
Local i As Long
Local j As Long
Local k As Long
Local maxvalue As Long
If g_PP = 12 Then
maxvalue = 65535
Else
maxvalue = 255
End If
For i = 0 To 7
For j = 0 To 7
k = g_ZigZag(i, j)
If g_QTable(Tqi).Qk(k) < 1 Or g_QTable(Tqi).Qk(k) > maxvalue Then
If %NOMSG = 0 Then MsgBox "Bad Quantization Table",,"JPEG encode error"
' Bad Quantization Table
End If
g_QTable(Tqi).FScale(k) = (g_EIDCTScale(i, j) + g_QTable(Tqi).Qk(k) \ 2) \ _
g_QTable(Tqi).Qk(k) ' g_QTable(Tqi).Qk(k)=1..maxval
' FScale always 0..65536/131072
Next j
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error4",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Huffman table generation
'------------------------------------------------------------------------------------
Sub BuildHuffman(ByRef TheHuff As HUFFMANTABLE, ByRef Freq() As Long)
Try
' 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.
Local i As Long
Local j As Long
Local k As Long
Local n As Long
Local w As Long
Local v1 As Long
Local v2 As Long
Dim others(256) As Long
Dim codesize(256) As Long
Dim vBits(256) As Long
Local swp As Long
Local swp2 As Long
' Initialization
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
w = Freq(i)
If w <> 0 Then
If w <= swp2 Then
If w <= swp Then
swp2 = swp
v2 = v1
swp = w
v1 = i
Else
swp2 = w
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
Do While others(v1) >= 0
v1 = others(v1)
codesize(v1) = codesize(v1) + 1
Loop
others(v1) = v2 ' Chain v2 onto v1's branch
codesize(v2) = codesize(v2) + 1 ' Increment all codesizes in v2's branch
Do While others(v2) >= 0
v2 = others(v2)
codesize(v2) = codesize(v2) + 1
Loop
Loop
' Count BITS [find the number of codes of each size]
n = 0
For i = 0 To 256
w = codesize(i)
If w <> 0 Then
vBits(w) = vBits(w) + 1
If n < w Then n = w ' Keep track of largest codesize
End If
Next i
' Adjust BITS [limit code lengths to 16 bits]
i = n
Do While i > 16
Do While vBits(i) > 0
For j = i - 2 To 1 Step -1 ' Since symbols are paired for the longest Huffman
If vBits(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
' (which is one bit shorter) is allocated to one
vBits(i) = vBits(i) - 2 ' of the pair; then, (skipping the BITS entry for
vBits(i - 1) = vBits(i - 1) + 1 ' that prefix length) a code word from the next
vBits(j + 1) = vBits(j + 1) + 2 ' shortest non-zero BITS entry is converted into
vBits(j) = vBits(j) - 1 ' a prefix for two code words one bit longer.
Loop
i = i - 1
Loop
vBits(i) = vBits(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]
For i = 1 To 16
TheHuff.vBits(i - 1) = vBits(i)
Next i
k = 0
For i = 1 To n
For j = 0 To 255
If codesize(j) = i Then
TheHuff.HuffVal(k) = j
k = k + 1
End If
Next j
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error5",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub ExpandHuffman(ByRef TheHuff As HUFFMANTABLE, ByVal MaxSymbol As Long)
Try
' 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.
Local i As Long ' Index for BITS
Local j As Long ' Index for HUFFVAL
Local k As Long ' Index for last HUFFVAL of length (i+1)
Local si As Long ' Huffman code size ( =2^i )
Local code As Long ' Huffman code
Local symbol As Long ' Huffman symbol
For i = 0 To 255
TheHuff.EHufLN(i) = 0
TheHuff.EHufSI(i) = 0 ' Clear existing values so we can
TheHuff.EHufCO(i) = -1 ' Check for duplicate huffman symbols
Next i
j = 0
si = 1
code = 0
For i = 0 To 15
k = j + TheHuff.vBits(i)
If k > 256 Then
If %NOMSG = 0 Then MsgBox "Bad Huffman Table (More than 256 symbols)",,"JPEG encode error"
' Bad Huffman Table
' (More than 256 symbols)
End If
If j = k Then ' No codes of length i+1
TheHuff.MinCode(i) = j - code
TheHuff.MaxCode(i) = -1
Else
TheHuff.MinCode(i) = j - code
Do While j < k
symbol = TheHuff.HuffVal(j) ' Read symbol, make sure it's valid
If symbol > MaxSymbol Then
If %NOMSG = 0 Then MsgBox "Bad Huffman Table (Invalid symbol)",,"JPEG encode error"
' Bad Huffman Table
' (Invalid symbol)
End If
If TheHuff.EHufCO(symbol) >= 0 Then
If %NOMSG = 0 Then MsgBox "Bad Huffman Table (Duplicate symbol)",,"JPEG encode error"
' Bad Huffman Table
' (Duplicate symbol)
End If
TheHuff.EHufLN(symbol) = i
TheHuff.EHufSI(symbol) = si ' Assign code for symbol
TheHuff.EHufCO(symbol) = code
code = code + 1
j = j + 1
Loop
TheHuff.MaxCode(i) = code - 1
End If
si = si + si
If code >= si Then
If %NOMSG = 0 Then MsgBox "Bad Huffman Table (Code does not fit into available bits)",,"JPEG encode error"
' Bad Huffman Table
' (Code does not fit into available bits)
End If
code = code + code
Next i
If j = 0 Then
If %NOMSG = 0 Then MsgBox "Bad Huffman Table (No huffman symbols???)",,"JPEG encode error"
' Bad Huffman Table
' (No huffman symbols???)
End If
Catch
If %NOMSG = 0 Then MsgBox "JPG Error6",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Function CodeLength(ByRef TheHuff As HUFFMANTABLE, ByRef Freq() As Long) As Long
Try
' Estimate a worstcase code length for an entire table
Local j As Long
Local k As Long
Local sum As Long
sum = 0
For j = 0 To 255
If Freq(j) <> 0 Then
k = TheHuff.EHufLN(j) + nBits(j) ' Length of size category + value, in bits
sum = sum + Freq(j) * k ' Sum all occurances of this coefficient, in bits
End If
Next j
Function = (sum + 7) \ 8
Catch
If %NOMSG = 0 Then MsgBox "JPG Error7",,Error$(Err)
End Try
End Function
'------------------------------------------------------------------------------------
' Entropy coding
'------------------------------------------------------------------------------------
Sub WriteBitsBegin()
g_m_Chr = 0
g_m_Bit = 128
End Sub
'------------------------------------------------------------------------------------
Sub WriteBitsEnd()
If g_m_Bit <> 128 Then WriteBits g_m_Bit, -1
End Sub
'------------------------------------------------------------------------------------
Sub WriteBits(ByVal mask As Long, ByVal code As Long)
Try
Do While mask > 0
If (code And mask) <> 0 Then g_m_Chr = (g_m_Chr Or g_m_Bit)
If g_m_Bit = 1 Then ' We completed a byte ...
g_m_Data(g_m_Ptr) = g_m_Chr ' Add it to the stream
If g_m_Chr = 255 Then ' Pad a zero byte and advance pointer
g_m_Ptr = g_m_Ptr + 1 ' Advance pointer
g_m_Data(g_m_Ptr) = 0 ' Insert zero
End If
g_m_Ptr = g_m_Ptr + 1 ' Advance pointer
g_m_Chr = 0 ' Clear byte buffer and reset bit index
g_m_Bit = 128
Else ' Increment to next bit position to write
g_m_Bit = g_m_Bit \ 2
End If
mask = mask \ 2
Loop
Catch
If %NOMSG = 0 Then MsgBox "JPG Error8",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub EncodeCoefficients(ByRef vData() As Integer, ByRef p As Long, ByRef Pred As Long, _
ByVal Td As Long, ByVal Ta As Long)
Try
' Use Huffman tables to compress a block of 64 quantized DCT coefficients to the local
' g_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.
Local r As Long
Local rs As Long
Local code As Long
Local p2 As Long
p2 = p + 64
code = vData(p) - Pred
Pred = vData(p)
p = p + 1
If code = 0 Then
WriteBits g_HuffDC(Td).EHufSI(0), g_HuffDC(Td).EHufCO(0) ' Append symbol for size category
Else
rs = nBits(code)
If code < 0 Then code = code - 1
WriteBits g_HuffDC(Td).EHufSI(rs), g_HuffDC(Td).EHufCO(rs) ' Append symbol for size category
WriteBits g_TwoR(rs), code ' Append diff
End If
r = 0
Do
code = vData(p)
If code = 0 Then
r = r + 16
Else
Do While r > 240
WriteBits g_HuffAC(Ta).EHufSI(240), g_HuffAC(Ta).EHufCO(240) ' Append RUN16 (a run of 16 zeros)
r = r - 256
Loop
rs = nBits(code)
If code < 0 Then code = code - 1
WriteBits g_HuffAC(Ta).EHufSI(r + rs), g_HuffAC(Ta).EHufCO(r + rs) ' Append run length, size category
WriteBits g_TwoR(rs), 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 g_HuffAC(Ta).EHufSI(0), g_HuffAC(Ta).EHufCO(0) ' Append EOB (end of block)
Catch
If %NOMSG = 0 Then MsgBox "JPG Error9",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Collecting statistics
'------------------------------------------------------------------------------------
' These procedures collect statistics of run-length and size categories of DCT coefficients
' so optimized Huffman tables can be generated to compress them.
Sub CollectStatisticsAC(ByRef vData() As Integer, ByRef FreqAC() As Long)
Try
Local code As Long
Local n As Long ' Number of coefficients in data()
Local p As Long ' Index for current data() coefficient
Local p2 As Long
Local r As Long ' Run length of zeros
Local rs As Long ' Run-length/Size-category Symbol
n = UBound(vData) + 1 ' +1 not necessary
p = 0
Do While p < n
p = p + 1
p2 = p + 63
r = 0
Do While p < p2 ' Should be equal on exit
code = vData(p) ' Is always <=|255| ??
If code = 0 Then
r = r + 16 ' 16*count of zeroes
Else
Do While r > 240
FreqAC(240) = FreqAC(240) + 1 ' Runs of 16 zeros
r = r - 256
Loop
rs = r + nBits(code) ' Number of bits for this code
FreqAC(rs) = FreqAC(rs) + 1 ' Freq of 16*nzeroes + nbits(code)+1
r = 0
End If
p = p + 1
Loop
If r <> 0 Then FreqAC(0) = FreqAC(0) + 1 ' EOB value
Loop
Catch
If %NOMSG = 0 Then MsgBox "JPG Error10",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub CollectStatisticsDCNonInterleaved(ByRef vData() As Integer, ByRef FreqDC() As Long)
Try
Local Pred As Long ' DC Predictor
Local n As Long ' Number of coefficients in data()
Local p As Long ' Index for current data() coefficient
Local rs As Long ' Size category for Diff
n = UBound(vData) + 1
p = 0
Pred = 0
Do While p < n
rs = nBits(vData(p) - Pred) ' Number of bits in delta from last value
Pred = vData(p)
FreqDC(rs) = FreqDC(rs) + 1 ' Frequencies of bitsizes
p = p + 64
Loop
Catch
If %NOMSG = 0 Then MsgBox "JPG Error11",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub CollectStatisticsDCInterleaved(ByRef vData() As Integer, ByRef FreqDC() As Long, _
ByVal vHi As Long, ByVal Vi As Long)
Try
Local p() As Long ' Index to .data in component f for scanline g
Local f As Long ' Index counter (component)
Local g As Long ' Index counter (sampling factor, vertical)
Local h As Long ' Index counter (sampling factor, horizontal)
Local i As Long ' Index counter (MCU horizontal)
Local j As Long ' Index counter (MCU vertical)
Local n As Long ' Number of coefficients in data()
Local s As Long ' Size category for Diff
Local Pred As Long ' DC Predictor
Local pLF As Long ' Line Feed for p in data
Local MCUr As Long ' Number of complete 8X8 blocks in rightmost MCU
Local MCUx As Long ' Number of MCUs per scanline
Local MCUy As Long ' Number of MCU scanlines
n = UBound(vData) + 1
ReDim p(Vi - 1)
MCUx = (g_XX + 8 * g_HMax - 1) \ (8 * g_HMax)
MCUy = ( g_YY + 8 * g_VMax - 1) \ (8 * g_VMax)
h = (-Int(-g_XX * vHi / g_HMax) + 7) \ 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 vHi) ' Number of complete 8X8 Blocks in rightmost MCU
If MCUr = 0 Then MCUr = vHi
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 vHi
s = nBits(vData(p(g - 1)) - Pred) ' Number of bits in diff
Pred = vData(p(g - 1))
FreqDC(s) = FreqDC(s) + 1
p(g - 1) = p(g - 1) + 64
Next h
Next g
Next i
' Rightmost MCU
For g = 1 To Vi
For h = 1 To vHi
If h > MCUr Then ' Pad with dummy block
s = 0
Else
s = nBits(vData(p(g - 1)) - Pred) ' Number of bits in diff
Pred = vData(p(g - 1))
p(g - 1) = p(g - 1) + 64
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 vHi
If p(g - 1) >= n Or (i = MCUx And h > MCUr) Then ' Pad with dummy block
s = 0
Else
s = nBits(vData(p(g - 1)) - Pred) ' Number of bits in Diff
Pred = vData(p(g - 1))
p(g - 1) = p(g - 1) + 64
End If
FreqDC(s) = FreqDC(s) + 1
Next h
Next g
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error12",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Image sampling
'------------------------------------------------------------------------------------
' 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]
Sub PBJPEG_SetSamplingFrequencies(ByVal H1 As Long, ByVal v1 As Long, _
ByVal H2 As Long, ByVal v2 As Long, _
ByVal H3 As Long, ByVal v3 As Long)
Local i As Long
Try
If H1 < 1 Or H1 > 4 Then
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err1"
' Invalid Sampling Value
End If
If v1 < 1 Or v1 > 4 Then
' Invalid Sampling Value
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err2"
End If
If (H2 Or H3 Or v2 Or v3) = 0 Then ' If H2,H3,V2,V3 are all zero ...
g_Nf = 1 ' Luminance only.
ReDim g_Comp(0)
g_Comp(0).vHi = 1 ' Set up for sampling Greyscale
g_Comp(0).Vi = 1 ' (Black and White picture)
g_Comp(0).ptrData = VarPtr(g_CompData0())
Else
If H2 < 1 Or H2 > 4 Then
' Invalid Sampling Value
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err3"
End If
If H3 < 1 Or H3 > 4 Then
' Invalid Sampling Value
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err4"
End If
If v2 < 1 Or v2 > 4 Then
' Invalid Sampling Value
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err5"
End If
If v3 < 1 Or v3 > 4 Then
' Invalid Sampling Value
If %NOMSG = 0 Then MsgBox "Invalid Sampling Value",,"Err6"
End If
g_Nf = 3 ' YCbCr
ReDim g_Comp(2)
g_Comp(0).vHi = H1
g_Comp(0).Vi = v1
g_Comp(0).Tqi = 0
g_Comp(0).ptrData = VarPtr(g_CompData0())
g_Comp(1).vHi = H2
g_Comp(1).Vi = v2
g_Comp(1).Tqi = 1
g_Comp(1).ptrData = VarPtr(g_CompData1())
g_Comp(2).vHi = H3
g_Comp(2).Vi = v3
g_Comp(2).Tqi = 1
g_Comp(2).ptrData = VarPtr(g_CompData2())
End If
g_HMax = -1
g_VMax = -1
For i = 0 To g_Nf - 1 ' Determine max h, v sampling factors
If g_HMax < g_Comp(i).vHi Then g_HMax = g_Comp(i).vHi
If g_VMax < g_Comp(i).Vi Then g_VMax = g_Comp(i).Vi
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error13",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Function PBJPEG_SampleHDC(ByVal lHDC As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lSrcLeft As Long, _
ByVal 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
Try
Local BI As BITMAPINFO ' Type containing the Bitmap information
Local hDIb As Long ' Handle to the DIBSection
Local hBmpOld As Long ' Handle to the old bitmap in the DC, for clear up
Local hDC As Long ' Handle to the Device context holding the DIBSection
Local pBits As Dword Ptr ' Address of memory pointing to the DIBSection's bits
Local f As Long ' Index counter for components
Local g As Long
Local vPixel() As Byte ' Byte array containing pixel data
Local lRowMod As Long ' Width of A Row in Bytes
Local xs As Long ' Sample width
Local ys As Long ' Sample height
Local xs8 As Long ' Sample width (padded to 8 pixel barrier)
Local ys8 As Long ' Sample height (padded to 8 pixel barrier)
Local xsLast As Long ' Sample width (for previous component)
Local ysLast As Long ' Sample height (for previous component)
Dim FScale(63) As Long
g_PP = 8
g_XX = lWidth ' The to be sampled image block
g_YY = lHeight ' The to be sampled image block
' Create a DIBSection to store Sampling(s) of the Image
hDC = CREATECOMPATIBLEDC(0)
If hDC = 0 Then
Function = 1 ' CreateCompatibleDC() API Failure
If %NOMSG = 0 Then MsgBox "CreateCompatibleDC() API Failure",,"JPEG encode error"
Else
'BI.bmiHeader.biSizeImage = ((BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC) * BI.bmiHeader.biHeight '4 byte barrier
'hDIb = CreateDIBSection2(hDC, BI, DIB_RGB_COLORS, lPtr, 0, 0)
lWidth = (g_XX + 7) And &HFFFFFFF8 ' 8 byte barrier for 8X8 data units
lHeight = (g_YY + 7) And &HFFFFFFF8
'MsgBox "width=" + Str$(lWidth) + "height=" + Str$(lHeight)
lRowMod = ((lWidth * 3 + 3) And &HFFFFFFFC)'(((lWidth * 24&) + 31&) And Not 31&) \ 8&
BI.bmiHeader.biSize = Len(BI.bmiHeader)
BI.bmiHeader.biWidth = lWidth
BI.bmiHeader.biHeight = -lHeight ' Top to bottom please
BI.bmiHeader.biPlanes = 1
BI.bmiHeader.biBitCount = 24
BI.bmiHeader.biCompression = %BI_RGB
BI.bmiHeader.biSizeImage = (lRowMod * lHeight) ' 4 byte barrier
hDIb = CREATEDIBSECTION(hDC, BI, %DIB_RGB_COLORS, ByVal VarPtr(pBits), 0, 0)
If hDIb = 0 Then
Function = 1 ' CreateDIBSection() API Failure
If %NOMSG = 0 Then MsgBox "CreateDIBSection() API Failure",,"JPEG encode error"
Else
GdiFlush
hBmpOld = SELECTOBJECT(hDC, hDIb) ' Select DIBSection into DC
If SETSTRETCHBLTMODE(hDC, %HALFTONE) = 0 Then SETSTRETCHBLTMODE hDC, %COLORONCOLOR
For f = 0 To g_Nf - 1
g_Comp(f).Ci = f + 1 ' Assign an ID to this component
xs = -Int(-g_XX * g_Comp(f).vHi / g_HMax) ' Determine Sample dimensions
ys = -Int(-g_YY * g_Comp(f).Vi / g_VMax)
xs8 = ((xs + 7) And &HFFFFFFF8) ' Sample dimensions with 8X8 barrier
ys8 = ((ys + 7) And &HFFFFFFF8)
If xs8 <> xsLast Or ys8 <> ysLast Then ' We need to Sample the Image
If xs = g_XX And ys = g_YY Then ' Just copy the image to our DIBSection
BITBLT hDC, 0, 0, xs, ys, lHDC, lSrcLeft, lSrcTop, %SRCCOPY
Else ' Resample/Resize the Image
STRETCHBLT hDC, 0, 0, xs, ys, lHDC, lSrcLeft, lSrcTop, lWidth, lHeight, %SRCCOPY
End If
If xs < xs8 Then ' Pad right of Sample to 8 block barrier
STRETCHBLT hDC, xs + 1, 0, xs8 - xs, ys, hDC, xs, 0, 1, ys, %SRCCOPY
End If
If ys < ys8 Then ' Pad bottom of Sample to 8 block barrier
STRETCHBLT hDC, 0, ys + 1, xs8, ys8 - ys, hDC, 0, ys, xs8, 1, %SRCCOPY
End If
End If
' Copy the DIB section's pixels to the vPixel array
' This is so dirty it hurts
ReDim vPixel((lRowMod * lHeight)-1)
'LogThis "Starting vPixel mod 4 = " + Str$((UBound(vPixel)+1) Mod 4)
For g = 0 To UBound(vPixel)
'If (g Mod 100000) = 0 Or (g > 2359196) Then LogThis "on vPixel " + Str$(g)
vPixel(g) = Peek(pBits + g) '<------ had GPF on large images on second encoding
Next g
'MoveMemory (ByVal VarPtr(vPixel(0)), _ ' // address Of Copy destination
' ByVal pBits, _ ' *Source, // address Of block To Copy
' ByVal UBound(vPixel) + 1) ' Length // Size, In bytes, Of block To Copy
'LogThis "UBound(vPixel)=" + Str$(UBound(vPixel))
For g = 0 To UBound(FScale)
FScale(g) = g_QTable(g_Comp(f).Tqi).FScale(g)
Next g
' Read 8X8 blocks of pixels, convert from RGB->YCbCr colorspace, FDCT and Quantize
' the data, store the results in .Data() of this component
Call TransformAndQuantize(vPixel(), f, FScale(), xs8, ys8, lRowMod)
'CALL TransformAndQuantize(vPixel(), f, g_QTable(g_Comp(f).Tqi).FScale(), xs8, ys8, lRowMod)
xsLast = xs
ysLast = ys
Next f
SELECTOBJECT hDC, hBmpOld ' Select CompatibleDC (unselect DIBSection)
DELETEOBJECT hDIb ' Delete DIBSection
End If
DELETEDC hDC ' Delete CompatibleDC
End If
Catch
If %NOMSG = 0 Then MsgBox "JPG Error14",,Error$(Err)
End Try
End Function
'------------------------------------------------------------------------------------
Function PBJPEG_AddComment(ByVal vComment As String) As Long
' Assigning a value to this property will add the text Comment to the JPEG file.
If Len(vComment) > 65535 Then
If %NOMSG = 0 Then MsgBox "Illegal Comment Length",,"JPEG encode error"
' Illegal Comment Length
Else
g_m_Comment = vComment
End If
End Function
'------------------------------------------------------------------------------------
' Emiting markers
'------------------------------------------------------------------------------------
Sub InsertJFIF()
Try
If g_m_Ptr + 17 > UBound(g_m_Data) Then
If %NOMSG = 0 Then MsgBox "Copymemory will write past bounds of g_m_Data()",,"JPEG encode error"
' Copymemory will write past bounds of g_m_Data()
Else
Poke VarPtr(g_m_Data(g_m_Ptr + 0)), &H1000E0FF ' APP0 Marker, Length(APP0)=16
Poke VarPtr(g_m_Data(g_m_Ptr + 4)), &H4649464A ' "JFIF"
Poke VarPtr(g_m_Data(g_m_Ptr + 8)), &H10100 ' "/0", Version Major=1, Version Minor=1
' Units=0 [0=pixel, 1=dpi, 2=dots/cm]
Poke VarPtr(g_m_Data(g_m_Ptr + 12)), &H1000100 ' Horizontal pixel density = 1 (dot per pixel)
' Vertical pixel density = 1 (dot per pixel)
Poke VarPtr(g_m_Data(g_m_Ptr + 16)), &H0 ' Thumbnail horizontal pixel count = 0
g_m_Ptr = g_m_Ptr + 18 ' Thumbnail vertical pixel count = 0
End If
Catch
If %NOMSG = 0 Then MsgBox "JPG Error15",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertSOF(ByVal SOFMarker As Long)
Try
Local i As Long ' Insert a Start Of Frame marker segment
Local Lx As Long ' PP, YY, XX, Nf, and Ci,Hi,Vi,Tqi, must already be set
Lx = 8 + 3 * g_Nf
g_m_Data(g_m_Ptr) = 255 ' SOF
g_m_Data(g_m_Ptr + 1) = SOFMarker And 255
g_m_Data(g_m_Ptr + 2) = Lx \ 256 ' Frame Header Length
g_m_Data(g_m_Ptr + 3) = Lx And 255
g_m_Data(g_m_Ptr + 4) = g_PP ' Sample precision [8, 12]
g_m_Data(g_m_Ptr + 5) = g_YY \ 256 ' Number of Lines
g_m_Data(g_m_Ptr + 6) = g_YY And 255
g_m_Data(g_m_Ptr + 7) = g_XX \ 256 ' Number of samples per line
g_m_Data(g_m_Ptr + 8) = g_XX And 255
g_m_Data(g_m_Ptr + 9) = g_Nf ' Number of image components in frame
g_m_Ptr = g_m_Ptr + 10
For i = 0 To g_Nf - 1 ' For each component ...
g_m_Data(g_m_Ptr) = g_Comp(i).Ci ' Component identifier
g_m_Data(g_m_Ptr + 1) = g_Comp(i).vHi * 16 Or g_Comp(i).Vi ' Horizontal/Vertical sampling factors
g_m_Data(g_m_Ptr + 2) = g_Comp(i).Tqi ' Quantization table selector
g_m_Ptr = g_m_Ptr + 3
Next i
Catch
If %NOMSG = 0 Then MsgBox "JPG Error16",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertCOM(ByVal TheComment As String)
Try
Local i As Long
Local Lx As Long
Lx = Len(TheComment) + 2
If Lx > 2 Then
g_m_Data(g_m_Ptr) = 255 ' COM marker
g_m_Data(g_m_Ptr + 1) = %COM
g_m_Data(g_m_Ptr + 2) = Lx \ 256 ' COM marker segment length
g_m_Data(g_m_Ptr + 3) = Lx And 255
g_m_Ptr = g_m_Ptr + 4
For i = 1 To Len(TheComment) ' Comment text
g_m_Data(g_m_Ptr) = Asc(Mid$(TheComment, i, 1))
g_m_Ptr = g_m_Ptr + 1
Next i
End If
Catch
If %NOMSG = 0 Then MsgBox "JPG Error17",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertDQT(ByVal MarkerPos As Long, ByVal Tqi As Long)
Try
Local i As Long ' Call with MarkerPos = g_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 g_m_Ptr < MarkerPos + 4 Then ' Insert Marker
g_m_Ptr = MarkerPos + 4
g_m_Data(g_m_Ptr - 4) = 255
g_m_Data(g_m_Ptr - 3) = %DQT
End If
For i = 0 To 63
If g_QTable(Tqi).Qk(i) > 255 Then Exit For
Next i
If i = 64 Then ' 8 bit precision
g_m_Data(g_m_Ptr) = Tqi
g_m_Ptr = g_m_Ptr + 1
For i = 0 To 63
g_m_Data(g_m_Ptr) = g_QTable(Tqi).Qk(i)
g_m_Ptr = g_m_Ptr + 1
Next i
Else ' 16 bit precision
If g_PP <> 12 Then
If %NOMSG = 0 Then MsgBox "Illegal precision in Quantization Table",,"JPEG encode error"
' Illegal precision in Quantization Table
End If
g_m_Data(g_m_Ptr) = Tqi Or 16
g_m_Ptr = g_m_Ptr + 1
For i = 0 To 63
g_m_Data(g_m_Ptr) = g_QTable(Tqi).Qk(i) \ 256
g_m_Data(g_m_Ptr + 1) = g_QTable(Tqi).Qk(i) And 255
g_m_Ptr = g_m_Ptr + 2
Next i
End If
g_m_Data(MarkerPos + 2) = (g_m_Ptr - MarkerPos - 2) \ 256& ' Insert Marker segment length
g_m_Data(MarkerPos + 3) = (g_m_Ptr - MarkerPos - 2) And 255&
Catch
If %NOMSG = 0 Then MsgBox "JPG Error18",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertDHT(ByVal MarkerPos As Long, ByVal HIndex As Long, ByVal isAC As Long)
Try
Local i As Long ' Call with MarkerPos = g_m_Ptr to insert a single table with its own DHT marker
Local j As Long ' Call multiple times with the same MarkerPos to include
' multiple tables under the same DHT marker
If g_m_Ptr < MarkerPos + 4 Then ' Insert Marker
g_m_Ptr = MarkerPos + 4
g_m_Data(g_m_Ptr - 4) = 255
g_m_Data(g_m_Ptr - 3) = %DHT
End If
If isAC Then
g_m_Data(g_m_Ptr) = HIndex Or 16
g_m_Ptr = g_m_Ptr + 1
j = 0
For i = 0 To 15
g_m_Data(g_m_Ptr) = g_HuffAC(HIndex).vBits(i)
g_m_Ptr = g_m_Ptr + 1
j = j + g_HuffAC(HIndex).vBits(i)
Next i
For i = 0 To j - 1
g_m_Data(g_m_Ptr) = g_HuffAC(HIndex).HuffVal(i)
g_m_Ptr = g_m_Ptr + 1
Next i
Else
g_m_Data(g_m_Ptr) = HIndex
g_m_Ptr = g_m_Ptr + 1
j = 0
For i = 0 To 15
g_m_Data(g_m_Ptr) = g_HuffDC(HIndex).vBits(i)
g_m_Ptr = g_m_Ptr + 1
j = j + g_HuffDC(HIndex).vBits(i)
Next i
For i = 0 To j - 1
g_m_Data(g_m_Ptr) = g_HuffDC(HIndex).HuffVal(i)
g_m_Ptr = g_m_Ptr + 1
Next i
End If
g_m_Data(MarkerPos + 2) = (g_m_Ptr - MarkerPos - 2) \ 256& ' Insert Marker segment length
g_m_Data(MarkerPos + 3) = (g_m_Ptr - MarkerPos - 2) And 255&
Catch
If %NOMSG = 0 Then MsgBox "JPG Error19",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertMarker(ByVal TheMarker As Long)
g_m_Data(g_m_Ptr) = 255
g_m_Data(g_m_Ptr + 1) = TheMarker
g_m_Ptr = g_m_Ptr + 2
End Sub
'------------------------------------------------------------------------------------
' Emiting scans
'------------------------------------------------------------------------------------
Sub InsertSOSNonInterleaved(ByVal CompIndex As Long, ByVal Td As Long, ByVal Ta As Long)
Try
' Insert an SOS marker and scan data for a non-interleaved Sequential scan.
Local p As Long ' Index to .data in component
Local n As Long
Local Pred As Long ' Predictor for DC coefficient
' Insert SOS Marker Segment
g_m_Data(g_m_Ptr) = 255 ' SOS Marker
g_m_Data(g_m_Ptr + 1) = %SOS
g_m_Data(g_m_Ptr + 2) = 8 \ 256 ' Marker Segment Length
g_m_Data(g_m_Ptr + 3) = 8 And 255
g_m_Data(g_m_Ptr + 4) = 1 ' Ns - Number of components in Scan [1-4]
g_m_Ptr = g_m_Ptr + 5
g_m_Data(g_m_Ptr) = g_Comp(CompIndex).Ci ' Csj - Component ID
g_m_Data(g_m_Ptr + 1) = Td * 16 Or Ta ' Td, Ta - DC, AC entropy coder selector
g_m_Ptr = g_m_Ptr + 2
g_m_Data(g_m_Ptr) = 0 ' Ss - Start of spectral selection
g_m_Data(g_m_Ptr + 1) = 63 ' Se - End of spectral selection
g_m_Data(g_m_Ptr + 2) = 0 ' Ah, Al - Successive approximation bit high/low
g_m_Ptr = g_m_Ptr + 3
' Insert non-interleaved sequential entropy coded data
p = 0
'n = UBOUND(g_Comp(CompIndex).vData) + 1
n = piaUBOUND(ByVal g_Comp(CompIndex).ptrData) + 1
Pred = 0
WriteBitsBegin
Do While p <> n
EncodeCoefficients ByVal g_Comp(CompIndex).ptrData, p, Pred, Td, Ta
Loop
WriteBitsEnd
Catch
If %NOMSG = 0 Then MsgBox "JPG Error20",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertSOSInterleaved(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long)
Try
' Insert an SOS marker and scan data for an interleaved Sequential scan.
Local f As Long ' Index counter (component)
Local g As Long ' Index counter (sampling factor, vertical)
Local h As Long ' Index counter (sampling factor, horizontal)
Local i As Long ' Index counter (MCU horizontal)
Local j As Long ' Index counter (MCU vertical)
Local Lx As Long ' Marker Segment Length
Local Ns As Long ' Number of components in Scan [1-4]
Local MCUx As Long ' Number of MCUs per scanline
Local MCUy As Long ' Number of MCU scanlines
Local p() As Long ' Index to .data in component f for scanline g
Local pLF() As Long ' Line Feed for p in .data for component f
Local Pred() As Long ' Predictor for DC coefficient in component f
Local 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
g_m_Data(g_m_Ptr) = 255 ' SOS Marker
g_m_Data(g_m_Ptr + 1) = %SOS
g_m_Data(g_m_Ptr + 2) = Lx \ 256 ' Marker Segment Length
g_m_Data(g_m_Ptr + 3) = Lx And 255
g_m_Data(g_m_Ptr + 4) = Ns ' Ns - Number of components in Scan [1-4]
g_m_Ptr = g_m_Ptr + 5
For i = FirstIndex To SecondIndex
g_m_Data(g_m_Ptr) = g_Comp(CompIndex(i)).Ci ' Csj
g_m_Data(g_m_Ptr + 1) = Td(i) * 16 Or Ta(i) ' Td, Ta
g_m_Ptr = g_m_Ptr + 2
Next i
g_m_Data(g_m_Ptr) = 0 ' Ss - Start of spectral selection
g_m_Data(g_m_Ptr + 1) = 63 ' Se - End of spectral selection
g_m_Data(g_m_Ptr + 2) = 0 ' Ah, Al - Successive approximation bit high/low
g_m_Ptr = g_m_Ptr + 3
' Insert interleaved sequential entropy coded data
ReDim p(FirstIndex To SecondIndex, g_VMax - 1)
ReDim Pred(FirstIndex To SecondIndex)
ReDim pLF(FirstIndex To SecondIndex)
ReDim MCUr(FirstIndex To SecondIndex)
MCUx = (g_XX + 8 * g_HMax - 1) \ (8 * g_HMax)
MCUy = (g_YY + 8 * g_VMax - 1) \ (8 * g_VMax)
For f = FirstIndex To SecondIndex
h = (-Int(-g_XX * g_Comp(CompIndex(f)).vHi / g_HMax) + 7) \ 8 ' Width of scanline in .data (MCUs)
For g = 0 To g_Comp(CompIndex(f)).Vi - 1 ' Initialize .data pointers
p(f, g) = 64 * h * g
Next g
pLF(f) = 64 * h * (g_Comp(CompIndex(f)).Vi - 1) ' Initialize .data pointer advancer
MCUr(f) = (h Mod g_Comp(CompIndex(f)).vHi) ' Number of complete 8X8 Blocks in rightmost MCU
If MCUr(f) = 0 Then MCUr(f) = g_Comp(CompIndex(f)).vHi
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
For g = 1 To g_Comp(CompIndex(f)).Vi
For h = 1 To g_Comp(CompIndex(f)).vHi
EncodeCoefficients ByVal g_Comp(CompIndex(f)).ptrData, p(f, g - 1), Pred(f), Td(f), Ta(f)
Next h
Next g
Next f
Next i
' Encode Rightmost MCU
For f = FirstIndex To SecondIndex ' 0 To Ns - 1
For g = 1 To g_Comp(CompIndex(f)).Vi
For h = 1 To g_Comp(CompIndex(f)).vHi
If h > MCUr(f) Then ' Pad with dummy block
Pad64(0) = Pred(f)
EncodeCoefficients Pad64(), 0, Pred(f), Td(f), Ta(f)
Else
EncodeCoefficients ByVal g_Comp(CompIndex(f)).ptrData, p(f, g - 1), Pred(f), Td(f), Ta(f)
End If
Next h
Next g
Next f
' Advance .data pointers
For f = FirstIndex To SecondIndex
For g = 0 To g_Comp(CompIndex(f)).Vi - 1
p(f, g) = p(f, g) + pLF(f)
Next g
Next f
Next j
' Encode Bottommost MCU Scanline
For i = 1 To MCUx
For f = FirstIndex To SecondIndex
For g = 1 To g_Comp(CompIndex(f)).Vi
For h = 1 To g_Comp(CompIndex(f)).vHi
If p(f, g - 1) > piaUBOUND(ByVal g_Comp(CompIndex(f)).ptrData) Or (i = MCUx And h > MCUr(f)) Then
' Pad with dummy block
Pad64(0) = Pred(f)
EncodeCoefficients Pad64(), 0, Pred(f), Td(f), Ta(f)
Else
EncodeCoefficients ByVal g_Comp(CompIndex(f)).ptrData, p(f, g - 1), Pred(f), Td(f), Ta(f)
End If
Next h
Next g
Next f
Next i
WriteBitsEnd
Catch
If %NOMSG = 0 Then MsgBox "JPG Error21",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
Sub InsertSequentialScans(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long)
Try
' Insert scan components CompIndex(FirstIndex) to CompIndex(SecondIndex) sequentially in compliance
' with JPEG rules. Components are interleaved whenever possible to emit as few scans as possible.
Local f As Long ' First Index
Local g As Long ' Second Index
Local nb As Long ' Number of 8X8 blocks in MCU
Local flag As Long ' True when ready to insert scan(s)
f = FirstIndex
g = FirstIndex
nb = 0
flag = %FALSE
Do While f <= SecondIndex
nb = nb + g_Comp(CompIndex(g)).vHi * g_Comp(CompIndex(g)).Vi
g = g + 1
If nb > 10 Then '%MAXNB = 10 ' Max 8X8 blocks in MCU (10 for JPEG compliance)
flag = %TRUE
If f <> g - 1 Then g = g - 1
Else
If (g - f) = 3 Or g > SecondIndex Then flag = %TRUE
End If
If flag Then
If f = g - 1 Then
InsertSOSNonInterleaved CompIndex(f), Td(f), Ta(f)
Else
InsertSOSInterleaved CompIndex(), Td(), Ta(), f, g - 1
End If
nb = 0
f = g
flag = %FALSE
End If
Loop
Catch
If %NOMSG = 0 Then MsgBox "JPG Error22",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Writing file
'------------------------------------------------------------------------------------
Function OptimizeHuffmanTables(ByRef CompIndex() As Long, ByRef Td() As Long, ByRef Ta() As Long, _
ByVal FirstIndex As Long, ByVal SecondIndex As Long) As Long
Try
' Optimize Huffman tables for the component indexes given.
' Returns an estimate of the number of bytes needed for entropy coded data.
' Estimate assumes a single scan, and entropy coded FF bytes are not followed by a zero stuff byte.
Local f As Long ' First Index
Local g As Long ' Second Index
Local i As Long
Local j As Long
Local k As Long
Local CodeLen As Long ' Total bytes required for entropy coded data
Local nb As Long ' Number of 8X8 blocks in MCU
Dim Freq(256) As Long ' Frequency count for optimizing Huffman tables
Local Freq2() As Long ' Copy of freq, used for calcultating entropy coded data size
Local IsInter() As Long ' True if component i will be interleaved
Local TdUsed() As Long ' True if g_HuffDC(i) is used
Local TaUsed() As Long ' True if g_HuffAC(i) is used
Local flag As Long ' True when ready to include scan(s)
ReDim IsInter(FirstIndex To SecondIndex)
ReDim TaUsed(3)
ReDim TdUsed(3)
' Determine which components will be interleaved by InsertSequentialScans(), which tables are used
f = FirstIndex
g = FirstIndex
nb = 0
flag = %FALSE
Do While f <= SecondIndex
nb = nb + g_Comp(CompIndex(g)).vHi * g_Comp(CompIndex(g)).Vi
g = g + 1
If nb > 10 Then '%MAXNB = 10 ' Max 8X8 blocks in MCU (10 for JPEG compliance)
flag = %TRUE
If f <> g - 1 Then g = g - 1
Else
If (g - f) = 3 Or g > SecondIndex Then flag = %TRUE
End If
If flag Then
If f = g - 1 Then
TdUsed(Td(f)) = %TRUE
TaUsed(Ta(f)) = %TRUE
IsInter(f) = %FALSE
Else
For i = f To g - 1
TdUsed(Td(i)) = %TRUE
TaUsed(Ta(i)) = %TRUE
IsInter(i) = %TRUE
Next i
End If
nb = 0
f = g
flag = %FALSE
End If
Loop
' Optimize huffman tables for the scan sequence
CodeLen = 0
For i = 0 To 3
If TdUsed(i) Then
For f = FirstIndex To SecondIndex
If Td(f) = i Then
If IsInter(f) Then
Call CollectStatisticsDCInterleaved(ByVal g_Comp(CompIndex(f)).ptrData, Freq(), _
g_Comp(CompIndex(f)).vHi, g_Comp(CompIndex(f)).Vi)
Else
Call CollectStatisticsDCNonInterleaved(ByVal g_Comp(CompIndex(f)).ptrData, Freq())
End If
End If
Next f
' Optimize and create this DC table
'Freq2() = Freq()
ReDim Freq2(UBound(Freq))
For k = 0 To UBound(Freq)
Freq2(k) = Freq(k)
Next k
Call BuildHuffman(g_HuffDC(i), Freq())
Call ExpandHuffman(g_HuffDC(i), IIf(g_PP = 12, 15, 11))
CodeLen = CodeLen + CodeLength(g_HuffDC(i), Freq2())
End If
If TaUsed(i) Then
For f = FirstIndex To SecondIndex
If Td(f) = i Then Call CollectStatisticsAC(ByVal g_Comp(CompIndex(f)).ptrData, Freq())
Next f
' Optimize and create this AC table
'Freq2() = Freq()
ReDim Freq2(UBound(Freq))
For k = 0 To UBound(Freq)
Freq2(k) = Freq(k)
Next k
Call BuildHuffman(g_HuffAC(i), Freq())
Call ExpandHuffman(g_HuffAC(i), 255)
CodeLen = CodeLen + CodeLength(g_HuffAC(i), Freq2())
End If
Next i
Function = CodeLen
Catch
If %NOMSG = 0 Then MsgBox "JPG Error23",,Error$(Err)
End Try
End Function
'------------------------------------------------------------------------------------
Function PBJPEG_SaveFile(FileName As String) As Long
Try
Dim CompIndex() As Long ' Indexes of Components to be included
Dim Td() As Long ' DC Huffman Table Selectors
Dim Ta() As Long ' AC Huffman Table Selectors
Dim FileNum As Integer
Dim i As Long
If Len(FileName) = 0 Then
Function = 1 ' FileName not given
Else
If (Len(Dir$(FileName, %NORMAL Or %READONLY Or %HIDDEN Or %SYSTEM Or %ARCHIVE)) > 0) Then
Function = 2 ' File already exists
Else
ReDim CompIndex(g_Nf - 1)
ReDim Td(g_Nf - 1)
ReDim Ta(g_Nf - 1)
For i = 0 To g_Nf - 1
CompIndex(i) = i
Td(i) = IIf(i = 0, 0, 1)
Ta(i) = IIf(i = 0, 0, 1)
Next i
i = OptimizeHuffmanTables(CompIndex(), Td(), Ta(), 0, g_Nf - 1)
' Estimate maximum possible file size needed
ReDim g_m_Data(i * 2 + 1000 + Len(g_m_Comment))
g_m_Ptr = 0
InsertMarker %SOI ' SOI - Start of Image
InsertJFIF ' JFIF
If Len(g_m_Comment) > 0 Then InsertCOM g_m_Comment ' COM - Comment
InsertCOM "PowerBasic JPEG Encoder by Philipp E. Weidmann" & $CRLF _
& "" & $CRLF _
& "Ported & adapted from cJPEGI by Ron van Tilbug and cJPEG by John Korejwa"
InsertDQT g_m_Ptr, 0 ' DQT - Define Quantization Tables
If g_Nf > 1 Then InsertDQT g_m_Ptr, 1
InsertSOF %SOF0 ' SOF - Start of Frame
InsertDHT g_m_Ptr, 0, %FALSE ' DHT - Define Huffman Tables
InsertDHT g_m_Ptr, 0, %TRUE
If g_Nf > 1 Then
InsertDHT g_m_Ptr, 1, %FALSE
InsertDHT g_m_Ptr, 1, %TRUE
End If
InsertSequentialScans CompIndex(), Td(), Ta(), 0, g_Nf - 1 ' SOS - Scan Data
InsertMarker %EOI ' EOI - End of Image
' Size the final byte array and write to file
ReDim Preserve g_m_Data(g_m_Ptr - 1)
FileNum = FreeFile
Open FileName For Binary Access Write As FileNum
Put #FileNum, , g_m_Data()
Close FileNum
Erase g_m_Data
End If
End If
Catch
If %NOMSG = 0 Then MsgBox "JPG Error24",,Error$(Err)
End Try
End Function
Sub PBJPEG_Reset()
'free up memory
Try
ReDim g_QLumin(1)
ReDim g_QChrom(1)
ReDim g_TwoP(1)
ReDim g_TwoR(1)
ReDim g_TwoB(1)
ReDim g_EIDCTScale(1)
ReDim g_DIDCTScale(1)
ReDim g_ZigZag(1)
g_PP = 0 ' Sample Precision [8, 12]
g_YY = 0 ' Number of lines [Image Height] after clipping
g_XX = 0 ' Number of samples per line [Image Width] after clipping
g_Nf = 0 ' Number of components in Frame
g_HMax = 0 ' Maximum horizontal sampling frequency
g_VMax = 0 ' Maximum vertical sampling frequency
ReDim g_m_Data(1)
g_m_Chr = 0 ' Current Character in g_m_Data
g_m_Ptr = 0 ' Byte index in g_m_Data
g_m_Bit = 0 ' Bit index in g_m_Chr
ReDim g_m_Block(1)
ReDim g_QTable(1)
ReDim g_HuffDC(1)
ReDim g_HuffAC(1)
ReDim g_Comp(1)
ReDim g_CompData0(1)
ReDim g_CompData1(1)
ReDim g_CompData2(1)
g_m_Quality = 0
g_m_Comment = ""
' Dim g_QLumin(63) As Global Byte
' Dim g_QChrom(63) As Global Byte
' Dim g_TwoP(31) As Global Long
' Dim g_TwoR(31) As Global Long
' Dim g_TwoB(255) As Global Byte
' Dim g_EIDCTScale(7, 7) As Global Long
' Dim g_DIDCTScale(7, 7) As Global Long
' Dim g_ZigZag(7, 7) As Global Long
' Dim g_m_Block(7, 7) As Global Long
' Dim g_QTable(3) As Global QUANTIZATIONTABLE
' Dim g_HuffDC(3) As Global HUFFMANTABLE
' Dim g_HuffAC(3) As Global HUFFMANTABLE
Catch
If %NOMSG = 0 Then MsgBox "JPG Error25a",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Initialization
'------------------------------------------------------------------------------------
Function PBJPEG_Initialize() As Long
Try
Local i As Long
Local j As Long
Local dx As Long
Local zz As Long
' Dimension global arrays
Dim g_QLumin(63) As Global Byte
Dim g_QChrom(63) As Global Byte
Dim g_TwoP(31) As Global Long
Dim g_TwoR(31) As Global Long
Dim g_TwoB(255) As Global Byte
Dim g_EIDCTScale(7, 7) As Global Long
Dim g_DIDCTScale(7, 7) As Global Long
Dim g_ZigZag(7, 7) As Global Long
Dim g_m_Block(7, 7) As Global Long
Dim g_QTable(3) As Global QUANTIZATIONTABLE
Dim g_HuffDC(3) As Global HUFFMANTABLE
Dim g_HuffAC(3) As Global HUFFMANTABLE
i = 0 ' Initialize the g_ZigZag() array, which maps out the
j = 0 ' zig-zag sequence of quantized DCT coefficients
dx = 1 ' in approximately low to high spatial frequencies
For zz = 0 To 63
g_ZigZag(i, j) = zz
i = i + dx
j = j - dx
If i > 7 Then ' 0 1 5 6 14 15 27 28
i = 7 ' 2 4 7 13 16 26 29 42
j = j + 2 ' 3 8 12 17 25 30 41 43
dx = -1 ' 9 11 18 24 31 40 44 53
ElseIf j > 7 Then ' 10 19 23 32 39 45 52 54
j = 7 ' 20 22 33 38 46 51 55 60
i = i + 2 ' 21 34 37 47 50 56 59 61
dx = 1 ' 35 36 48 49 57 58 62 63
ElseIf i < 0 Then
i = 0 ' Check (j>7) first
dx = 1
ElseIf j < 0 Then
j = 0
dx = -1
End If
Next zz
' Luminance Quantization table for Quality = 50
g_QLumin(0) = 16: g_QLumin(1) = 11: g_QLumin(2) = 12: g_QLumin(3) = 14
g_QLumin(4) = 12: g_QLumin(5) = 10: g_QLumin(6) = 16: g_QLumin(7) = 14
g_QLumin(8) = 13: g_QLumin(9) = 14: g_QLumin(10) = 18: g_QLumin(11) = 17
g_QLumin(12) = 16: g_QLumin(13) = 19: g_QLumin(14) = 24: g_QLumin(15) = 40
g_QLumin(16) = 26: g_QLumin(17) = 24: g_QLumin(18) = 22: g_QLumin(19) = 22
g_QLumin(20) = 24: g_QLumin(21) = 49: g_QLumin(22) = 35: g_QLumin(23) = 37
g_QLumin(24) = 29: g_QLumin(25) = 40: g_QLumin(26) = 58: g_QLumin(27) = 51
g_QLumin(28) = 61: g_QLumin(29) = 60: g_QLumin(30) = 57: g_QLumin(31) = 51
g_QLumin(32) = 56: g_QLumin(33) = 55: g_QLumin(34) = 64: g_QLumin(35) = 72
g_QLumin(36) = 92: g_QLumin(37) = 78: g_QLumin(38) = 64: g_QLumin(39) = 68
g_QLumin(40) = 87: g_QLumin(41) = 69: g_QLumin(42) = 55: g_QLumin(43) = 56
g_QLumin(44) = 80: g_QLumin(45) = 109: g_QLumin(46) = 81: g_QLumin(47) = 87
g_QLumin(48) = 95: g_QLumin(49) = 98: g_QLumin(50) = 103: g_QLumin(51) = 104
g_QLumin(52) = 103: g_QLumin(53) = 62: g_QLumin(54) = 77: g_QLumin(55) = 113
g_QLumin(56) = 121: g_QLumin(57) = 112: g_QLumin(58) = 100: g_QLumin(59) = 120
g_QLumin(60) = 92: g_QLumin(61) = 101: g_QLumin(62) = 103: g_QLumin(63) = 99
' Chrominance Quantization table for Quality = 50
g_QChrom(0) = 17: g_QChrom(1) = 18: g_QChrom(2) = 18: g_QChrom(3) = 24
g_QChrom(4) = 21: g_QChrom(5) = 24: g_QChrom(6) = 47: g_QChrom(7) = 26
g_QChrom(8) = 26: g_QChrom(9) = 47: g_QChrom(10) = 99: g_QChrom(11) = 66
g_QChrom(12) = 56: g_QChrom(13) = 66: g_QChrom(14) = 99: g_QChrom(15) = 99
g_QChrom(16) = 99: g_QChrom(17) = 99: g_QChrom(18) = 99: g_QChrom(19) = 99
g_QChrom(20) = 99: g_QChrom(21) = 99: g_QChrom(22) = 99: g_QChrom(23) = 99
g_QChrom(24) = 99: g_QChrom(25) = 99: g_QChrom(26) = 99: g_QChrom(27) = 99
g_QChrom(28) = 99: g_QChrom(29) = 99: g_QChrom(30) = 99: g_QChrom(31) = 99
g_QChrom(32) = 99: g_QChrom(33) = 99: g_QChrom(34) = 99: g_QChrom(35) = 99
g_QChrom(36) = 99: g_QChrom(37) = 99: g_QChrom(38) = 99: g_QChrom(39) = 99
g_QChrom(40) = 99: g_QChrom(41) = 99: g_QChrom(42) = 99: g_QChrom(43) = 99
g_QChrom(44) = 99: g_QChrom(45) = 99: g_QChrom(46) = 99: g_QChrom(47) = 99
g_QChrom(48) = 99: g_QChrom(49) = 99: g_QChrom(50) = 99: g_QChrom(51) = 99
g_QChrom(52) = 99: g_QChrom(53) = 99: g_QChrom(54) = 99: g_QChrom(55) = 99
g_QChrom(56) = 99: g_QChrom(57) = 99: g_QChrom(58) = 99: g_QChrom(59) = 99
g_QChrom(60) = 99: g_QChrom(61) = 99: g_QChrom(62) = 99: g_QChrom(63) = 99
' Encoding Quantization Scalars (values are 0.. 0.5 scaled by 131072)
' Call GenEIDCT
g_EIDCTScale(0, 0) = 16384: g_EIDCTScale(0, 1) = 16384: g_EIDCTScale(0, 2) = 25080: g_EIDCTScale(0, 3) = 23170
g_EIDCTScale(0, 4) = 32768: g_EIDCTScale(0, 5) = 23170: g_EIDCTScale(0, 6) = 21407: g_EIDCTScale(0, 7) = 32768
g_EIDCTScale(1, 0) = 16384: g_EIDCTScale(1, 1) = 16384: g_EIDCTScale(1, 2) = 25080: g_EIDCTScale(1, 3) = 23170
g_EIDCTScale(1, 4) = 32768: g_EIDCTScale(1, 5) = 23170: g_EIDCTScale(1, 6) = 21407: g_EIDCTScale(1, 7) = 32768
g_EIDCTScale(2, 0) = 25080: g_EIDCTScale(2, 1) = 25080: g_EIDCTScale(2, 2) = 38390: g_EIDCTScale(2, 3) = 35468
g_EIDCTScale(2, 4) = 50159: g_EIDCTScale(2, 5) = 35468: g_EIDCTScale(2, 6) = 32768: g_EIDCTScale(2, 7) = 50159
g_EIDCTScale(3, 0) = 23170: g_EIDCTScale(3, 1) = 23170: g_EIDCTScale(3, 2) = 35468: g_EIDCTScale(3, 3) = 32768
g_EIDCTScale(3, 4) = 46341: g_EIDCTScale(3, 5) = 32768: g_EIDCTScale(3, 6) = 30274: g_EIDCTScale(3, 7) = 46341
g_EIDCTScale(4, 0) = 32768: g_EIDCTScale(4, 1) = 32768: g_EIDCTScale(4, 2) = 50159: g_EIDCTScale(4, 3) = 46341
g_EIDCTScale(4, 4) = 65536: g_EIDCTScale(4, 5) = 46341: g_EIDCTScale(4, 6) = 42813: g_EIDCTScale(4, 7) = 65536
g_EIDCTScale(5, 0) = 23170: g_EIDCTScale(5, 1) = 23170: g_EIDCTScale(5, 2) = 35468: g_EIDCTScale(5, 3) = 32768
g_EIDCTScale(5, 4) = 46341: g_EIDCTScale(5, 5) = 32768: g_EIDCTScale(5, 6) = 30274: g_EIDCTScale(5, 7) = 46341
g_EIDCTScale(6, 0) = 21407: g_EIDCTScale(6, 1) = 21407: g_EIDCTScale(6, 2) = 32768: g_EIDCTScale(6, 3) = 30274
g_EIDCTScale(6, 4) = 42813: g_EIDCTScale(6, 5) = 30274: g_EIDCTScale(6, 6) = 27969: g_EIDCTScale(6, 7) = 42813
g_EIDCTScale(7, 0) = 32768: g_EIDCTScale(7, 1) = 32768: g_EIDCTScale(7, 2) = 50159: g_EIDCTScale(7, 3) = 46341
g_EIDCTScale(7, 4) = 65536: g_EIDCTScale(7, 5) = 46341: g_EIDCTScale(7, 6) = 42813: g_EIDCTScale(7, 7) = 65536
' Powers of 2
Call Init_BitMasks
' The number of bits in value
g_TwoB(0) = 0: g_TwoB(1) = 1: g_TwoB(2) = 2: g_TwoB(3) = 2
For i = 4 To 7
g_TwoB(i) = 3
Next i
For i = 8 To 15
g_TwoB(i) = 4
Next i
For i = 16 To 31
g_TwoB(i) = 5
Next i
For i = 32 To 63
g_TwoB(i) = 6
Next i
For i = 64 To 127
g_TwoB(i) = 7
Next i
For i = 128 To 255
g_TwoB(i) = 8
Next i
PBJPEG_SetSamplingFrequencies 2, 2, 1, 1, 1, 1
PBJPEG_SetQuality 75
Catch
If %NOMSG = 0 Then MsgBox "JPG Error25",,Error$(Err)
End Try
End Function
'------------------------------------------------------------------------------------
Sub Init_BitMasks()
Try
Local i As Long
Dim sb(31) As Long
' Requires PB 8
' ARRAY ASSIGN sb() = &H1&, &H2&, &H4&, &H8&, _
' &H10&, &H20&, &H40&, &H80&, _
' &H100&, &H200&, &H400&, &H800&, _
' &H1000&, &H2000&, &H4000, &H8000&, _
' &H10000, &H20000, &H40000, &H80000, _
' &H100000, &H200000, &H400000, &H800000, _
' &H1000000, &H2000000, &H4000000, &H8000000, _
' &H10000000, &H20000000, &H40000000, &H80000000
sb(0) = &H1&
sb(1) = &H2&
sb(2) = &H4&
sb(3) = &H8&
sb(4) = &H10&
sb(5) = &H20&
sb(6) = &H40&
sb(7) = &H80&
sb(8) = &H100&
sb(9) = &H200&
sb(10) = &H400&
sb(11) = &H800&
sb(12) = &H1000&
sb(13) = &H2000&
sb(14) = &H4000
sb(15) = &H8000&
sb(16) = &H10000
sb(17) = &H20000
sb(18) = &H40000
sb(19) = &H80000
sb(20) = &H100000
sb(21) = &H200000
sb(22) = &H400000
sb(23) = &H800000
sb(24) = &H1000000
sb(25) = &H2000000
sb(26) = &H4000000
sb(27) = &H8000000
sb(28) = &H10000000
sb(29) = &H20000000
sb(30) = &H40000000
sb(31) = &H80000000
For i = 0 To 30
g_TwoP(i) = sb(i)
g_TwoR(i + 1) = sb(i)
Next i
g_TwoP(31) = sb(31)
Catch
If %NOMSG = 0 Then MsgBox "JPG Error27",,Error$(Err)
End Try
End Sub
'------------------------------------------------------------------------------------
' Uncomment this to generate the table above
Sub GenEIDCT()
' DIM t(7) AS DOUBLE
' LOCAL i AS LONG, j AS LONG
'
' %PI = 3.14159265358979
'
' t(0) = SIN(%PI / 4) / 2
' t(1) = 1 / SQR(8)
' t(2) = 1 / (2 * SIN(3 * %PI / 8))
' t(3) = 0.5
' t(4) = SIN(%PI / 4)
' t(5) = 0.5
' t(6) = SIN(3 * %PI / 8) / 2
' t(7) = 1 / SQR(2)
'
' OPEN "EIDCT.txt" FOR OUTPUT AS #1
'
' FOR i = 0 TO 7
' FOR j = 0 TO 7
' g_EIDCTScale(i, j) = 131072 * t(i) * t(j)
' PRINT #1, "g_EIDCTScale(" & i & "," & j & ")=" & g_EIDCTScale(i, j)
' NEXT j
' NEXT i
'
' CLOSE #1
End Sub
'------------------------------------------------------------------------------------
' The routine below is functionally equivalent to that below but entirely in integers only
' nBits = Int((Log(Abs(v)) * 1.442695040889))+1 '1/log(2) v<>0, 0 if v=0
Function nBits(ByVal v As Long) As Long ' Effectively binary search for Log2 -32768<v<32767
Try
If v < 0 Then v = -v
If v < %TWOE08 Then ' Use linear table lookup for values <256
nBits = g_TwoB(v)
Else ' Use binary search
' IF v < %TWOE08 THEN ' 0..255 bits 7..0
' IF v < %TWOE04 THEN ' 0.. 15 bits 3..0
' IF v < %TWOE02 THEN ' 0.. 1 bits 1..0
' IF v < %TWOE01 THEN
' nBits = 1
' ELSE
' nBits = 2
' END IF
' ELSEIF v < %TWOE03 THEN ' 4.. 7 bits 3..2
' nBits = 3
' ELSE
' nBits = 4
' END IF
' ELSE ' 16..255 bits 7..4
'
' IF v < %TWOE06 THEN ' 16.. 63 bits 5..4
' IF v < %TWOE05 THEN
' nBits = 5
' ELSE
' nBits = 6
' END IF
' ELSEIF v < %TWOE07 THEN ' 64..127 bits 7..6
' nBits = 7
' ELSE
' nBits = 8
' END IF
' END IF
' ELSE ' 256..32768 bits 15..8
If v < %TWOE12 Then ' Bits 11..8
If v < %TWOE10 Then ' Bits 9..8
If v < %TWOE09 Then
nBits = 9
Else
nBits = 10
End If
ElseIf v < %TWOE11 Then
nBits = 11
Else ' Bits 11..10
nBits = 12
End If
Else ' Bits 15..12
If v < %TWOE14 Then ' Bits 13..12
If v < %TWOE13 Then
nBits = 13
Else
nBits = 14
End If
ElseIf v < %TWOE15 Then ' Bits 15..14
nBits = 15
Else
nBits = 16
End If
End If
End If
' END IF
Catch
If %NOMSG = 0 Then MsgBox "JPG Error28",,Error$(Err)
End Try
End Function
'===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!
#Compile Exe
#Include "WIN32API.INC"
#Include "jpg.inc"
'===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!
Function SaveClipboardPic(ByVal hWnd As Long,sFilename As String, iQuality As Long) As Long
Local iRet As Long
Local hBitmap As Dword
Local dcBitmap As Dword
Local hDesktop As Dword
Local bm As Bitmap
hWnd = GetDesktopWindow()
hDesktop = GetDC(hWnd)
Call OpenClipboard(hWnd)
hBitmap = GetClipboardData(%CF_BITMAP)
If (hBitmap= 0) Then
MsgBox "No image found in clipboard. Press Prt Screen first.",,"SaveClipboardPic Error"
Else
If GetObject(hBitmap,Len(bm),bm) Then
dcBitmap = CreateCompatibleDC(hDesktop)
If dcBitMap = 0 Then
MsgBox "Failed to get DC",,"SaveClipboardPic Error"
Else
iRet = SelectObject(dcBitmap, hBitmap)
If iRet = 0 Or iRet = %GDI_ERROR Then MsgBox "SelectObject Error ",,"SaveClipboardPic Error" + Str$(iRet)
Try 'see if we need to remove existing file
Kill sFilename
Catch
End Try
'JPEG routines
PBJPEG_SetSamplingFrequencies 2, 2, 1, 1, 1, 1
PBJPEG_SetQuality iQuality
' Save to JFIF (JPEG File Interchange Format) file
PBJPEG_SampleHDC dcBitmap, bm.bmwidth, bm.bmheight, 0, 0
PBJPEG_SaveFile sFilename
'PBJPEG_Reset()
DeleteDC dcBitmap
Function = %TRUE
End If
Else
MsgBox "Error Getting BM Structure",,"SaveClipboardPic Error"
End If
'Call EmptyClipboard()
End If
Call CloseClipboard()
If hDesktop Then ReleaseDC hWnd, hDesktop
End Function
'===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!===!
Function PBMain()
PBJPEG_Initialize 'must run first to setup JPG routines
if SaveClipboardPic(GetDesktopWindow(), "SavedPic.jpg", 90) then 'note 90 is the quality of compression (smaller file or better quality)
msgbox "Clipboard saved to SavedPic.jpg",,"Worked"
end if
End Function
Comment