📄 clsjpeg.cls
字号:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "ClsJPEG"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'////////////////////////////////////////////////////
'
' JPEG Encoder Class
' Written by John Korejwa <korejwa@tiac.net>
'
'////////////////////////////////////////////////////
Option Explicit
Option Base 0
'霍夫曼码
Private Const SOF0 As Long = &HC0&
Private Const SOF1 As Long = &HC1&
Private Const SOF2 As Long = &HC2&
Private Const SOF3 As Long = &HC3&
Private Const SOF5 As Long = &HC5&
Private Const SOF6 As Long = &HC6&
Private Const SOF7 As Long = &HC7&
'算求编码
Private Const JPG As Long = &HC8&
Private Const SOF9 As Long = &HC9&
Private Const SOF10 As Long = &HCA&
Private Const SOF11 As Long = &HCB&
Private Const SOF13 As Long = &HCD&
Private Const SOF14 As Long = &HCE&
Private Const SOF15 As Long = &HCF&
'其他
Private Const DHT As Long = &HC4& '定义霍夫曼码表
Private Const DAC As Long = &HCC&
Private Const RSTm As Long = &HD0&
Private Const RSTm2 As Long = &HD7&
Private Const SOI As Long = &HD8& '图片开始
Private Const EOI As Long = &HD9& '图片结束
Private Const SOS As Long = &HDA&
Private Const DQT As Long = &HDB&
Private Const DNL As Long = &HDC&
Private Const DRI As Long = &HDD&
Private Const DHP As Long = &HDE&
Private Const EXP As Long = &HDF&
Private Const APP0 As Long = &HE0&
Private Const APPF As Long = &HEF&
Private Const JPGn As Long = &HF0&
Private Const JPGn2 As Long = &HFD&
Private Const COM As Long = &HFE&
Private Const RESm As Long = &H2&
Private Const RESm2 As Long = &HBF&
Private Const TEM As Long = &H1&
'下面数组请不要更改
Private QLumin(63) As Integer
Private QChrom(63) As Integer
Private FDCTScale(7) As Double
Private IDCTScale(7) As Double
Private ZigZag(7, 7) As Long
'API 常数, SetStretchBltMode中使用
Private Const BLACKONWHITE As Long = 1
Private Const COLORONCOLOR As Long = 3
Private Const HALFTONE As Long = 4 'Win 95, 98, ME不支持
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0
'用于 DIB 数据
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函数需要创建DIB数据
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)
'用户自定类型用于JPEG编码
Private Type QUANTIZATIONTABLE
Qk(63) As Integer '量子化
FScale(63) As Single '量子化 FDCT 输出
IScale(63) As Single '反量子化 IDCT 输入
End Type
Private Type HUFFMANTABLE
BITS(15) As Byte '霍夫曼码长
HUFFVAL(255) As Byte '值
EHUFSI(255) As Long
EHUFCO(255) As Long
MINCODE(15) As Long
MAXCODE(15) As Long
End Type
Private Type COMPONENT
Ci As Long '样件ID [0-255]
Hi As Long '水平采样因子 [1-4]
Vi As Long '垂直采样因子 [1-4]
Tqi As Long '量子化表部分 [0-3]
data() As Integer 'DCT Coefficients
End Type
Private PP As Long '采样精度 [8, 12]
Private YY As Long '行数 [Image Height]
Private XX As Long '每行采样数 [Image Width]
Private Nf As Long '样件数
Private HMax As Long '水平最大采样频率
Private VMax As Long '垂直最大采样频率
Private m_Data() As Byte 'JPEG文件数据
Private m_Chr As Long 'm_Data中的一个数据
Private m_Ptr As Long 'm_Chr在m_Data中的索引
Private m_Bit As Long 'm_Chr中的位
Private m_Block(7, 7) As Single '用于计算 DCT 的缓冲区
Private QTable(3) As QUANTIZATIONTABLE '4 量子化表
Private HuffDC(3) As HUFFMANTABLE '4 DC 霍夫曼码表
Private HuffAC(3) As HUFFMANTABLE '4 AC 霍夫曼码表
Private Comp() As COMPONENT
Private m_Quality As Long
Private m_Comment As String
Private Sub FDCT() '处理8X8块
Static t0 As Single
Static t1 As Single
Static t2 As Single
Static t3 As Single
Static t4 As Single
Static t5 As Single
Static t6 As Single
Static t7 As Single
Static t8 As Single
Static i As Long
For i = 0 To 7 '每行处理一单位 FDCT
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
For i = 0 To 7 '每列处理一单位 FDCT
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
End Sub
'生成霍夫曼码表
Private Sub OptimizeHuffman(TheHuff As HUFFMANTABLE, freq() As Long)
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
others(i) = -1
Next
freq(256) = 1
Do
V1 = -1
V2 = -1
swp = 2147483647
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
If V2 = -1 Then
freq(V1) = 0
Exit Do
End If
freq(V1) = freq(V1) + freq(V2)
freq(V2) = 0
codesize(V1) = codesize(V1) + 1
While (others(V1) >= 0)
V1 = others(V1)
codesize(V1) = codesize(V1) + 1
Wend
others(V1) = V2
codesize(V2) = codesize(V2) + 1
While (others(V2) >= 0)
V2 = others(V2)
codesize(V2) = codesize(V2) + 1
Wend
Loop
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)
End If
Next
i = n
While i > 16
While BITS(i) > 0
For j = i - 2 To 1 Step -1
If BITS(j) > 0 Then Exit For
Next
BITS(i) = BITS(i) - 2
BITS(i - 1) = BITS(i - 1) + 1
BITS(j + 1) = BITS(j + 1) + 2
BITS(j) = BITS(j) - 1
Wend
i = i - 1
Wend
BITS(i) = BITS(i) - 1
With TheHuff
For i = 1 To 16
.BITS(i - 1) = BITS(i)
Next
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
Next
End With
End Sub
Private Sub ExpandHuffman(TheHuff As HUFFMANTABLE, Optional MaxSymbol As Long = 255)
Dim i As Long
Dim j As Long
Dim k As Long
Dim si As Long
Dim code As Long
Dim symbol As Long
With TheHuff
For i = 0 To 255
.EHUFSI(i) = 0
.EHUFCO(i) = -1
Next
j = 0
si = 1
code = 0
For i = 0 To 15
k = j + .BITS(i)
If k > 256 Then Err.Raise 1, , "错误霍夫曼码表"
If j = k Then
.MINCODE(i) = j - code
.MAXCODE(i) = -1
Else
.MINCODE(i) = j - code
While j < k
symbol = .HUFFVAL(j)
If symbol > MaxSymbol Then Err.Raise 1, , "错误霍夫曼码表"
If .EHUFCO(symbol) >= 0 Then Err.Raise 1, , "错误霍夫曼码表"
.EHUFSI(symbol) = si
.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, , "错误霍夫曼码表"
code = code * 2
Next
If j = 0 Then Err.Raise 1, , "错误霍夫曼码表"
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -