📄 cjpeg.cls
字号:
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]
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -