www.pudn.com > bmp2toJPEG.rar > mSaveJPEG.bas
Attribute VB_Name = "mSaveJPEG"
Option Explicit
Private Type BITMAPINFOHEADER '40 bytes
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To &HFF) As RGBQUAD
End Type
Private Const BI_RGB As Long = 0&
Private Declare Function GetObjectAPI Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS As Long = 0
Private Const DIB_PAL_COLORS As Long = 1
Private Declare Function SetDIBitsToDevice Lib "gdi32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dX As Long, ByVal dY As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long
'================================================
Public Enum JPEGInfoConstants
JIC_QualityMask = &HFF& '质量部分掩码（0~100）
JIC_Hy2 = &H100& '彩色JPEG中，Y分量水平采样是2
JIC_Vy2 = &H200& '彩色JPEG中，Y分量垂直采样是2
JIC_Gray = &H400& '灰度JPEG。没有这个标记表示是彩色JPEG
JIC_AutoDHT = &H800& '自动生成最优化Huffman表。没有这个标记表示用默认Huffman表
'暂时不支持自动生成最优化Huffman表（算法比较复杂，程序的结构就写的比较乱）
End Enum
Private Type JPEGImage
hFile As Long '文件号
Width As Long '宽度
Height As Long '高度
Flags As JPEGInfoConstants
Items As Long '颜色分量数(1 or 3)
DQTItems As Long 'DQT项目数
OldDC(1 To 3) '旧的DC系数
BitBuff As Long '位缓冲区
BitUsed As Long '位缓冲区中使用的位
Block(0 To 63) As Long '一个数据块
CurItem As Long '当前颜色分量索引（1~3）
CurType As Long '当前亮度/色度（0/1）
CurDCAC As Long '当前DC/AC（0/1）
DQT(0 To 63, 0 To 1) As Long
'反正使用默认Huffamn表或自动生成最佳Huffman表，所以不需要保存DHT
End Type
'将Picture对象保存为JPEG文件
Public Function JPEGSavePic(ByRef Image As Picture, ByRef FileName As String, Flags As JPEGInfoConstants) As Boolean
If Image.Type <> VBRUN.PictureTypeConstants.vbPicTypeBitmap Then Exit Function
If (Flags And JIC_QualityMask) > 100 Then Exit Function
Dim Rc As Long
'== 初始化数据
Dim bm As BITMAP
If GetObjectAPI(Image.Handle, Len(bm), bm) = 0 Then Exit Function
Dim BI As BITMAPINFO
Dim ItemBytes As Long, LineBytes As Long
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = bm.bmWidth
.biHeight = bm.bmHeight
.biPlanes = bm.bmPlanes
ItemBytes = 3
.biBitCount = 8 * ItemBytes
.biCompression = BI_RGB
LineBytes = ((.biWidth * .biBitCount + 31&) And &HFFFFFFE0) \ 8
.biSizeImage = LineBytes * .biHeight
Dim MapData() As Byte
ReDim MapData(0 To .biSizeImage)
End With
'== 得到图像数据
'Dim hDC As Long
'Dim hOldMap As Long
'
'hDC = CreateCompatibleDC(0)
'If hDC = 0 Then Exit Function
'hOldMap = SelectObject(hDC, Image.Handle)
'
'Rc = GetDIBits(hDC, Image.Handle, 0, bm.bmHeight, MapData(0), BI, DIB_RGB_COLORS)
'
'Call SelectObject(hDC, hOldMap)
'Call DeleteDC(hDC)
'VB的Picture对象与StdPicture对象等价
'它们都继承了IPictureDisp和IPicture接口
'只不过IPictureDisp是Picture/StdPicture对象的标准接口
Dim IPic As IPicture
Set IPic = Image
Rc = GetDIBits(IPic.CurDC, IPic.Handle, 0, bm.bmHeight, MapData(0), BI, DIB_RGB_COLORS)
Set IPic = Nothing
If Rc = 0 Then Exit Function
'== 开始保存
JPEGSavePic = JPEGSave(VarPtr(BI), VarPtr(MapData(0)), FileName, Flags)
End Function
'将DIB位图数据保存为JPEG文件
Public Function JPEGSave(ByVal lpBI As Long, ByVal lpBits As Long, ByRef FileName As String, Flags As JPEGInfoConstants) As Boolean
If lpBI = 0 Then Exit Function
If lpBits = 0 Then Exit Function
If Len(FileName) = 0 Then Exit Function
mBit.Init
mJPEG.Init
'== 检查DIB
Dim MyImage As JPEGImage
Dim BI As BITMAPINFOHEADER
Dim ItemBytes As Long, LineBytes As Long
CopyMemory BI, ByVal lpBI, Len(BI)
With BI
If .biWidth < 0 Or .biWidth > &HFFFF& Then Exit Function
If .biHeight < 0 Or .biHeight > &HFFFF& Then Exit Function
Select Case .biBitCount
Case 24, 32
Case Else
Exit Function
End Select
If .biPlanes <> 1 Then Exit Function
If .biCompression <> BI_RGB Then Exit Function
MyImage.Width = .biWidth
MyImage.Height = .biHeight
MyImage.Flags = Flags
ItemBytes = .biBitCount \ 8
LineBytes = ((.biWidth * .biBitCount + 31&) And &HFFFFFFE0) \ 8
End With
'初始化编码
If JPEGEncodeBegin(MyImage, FileName) = False Then Exit Function
'== 写图像压缩数据
Const DCTSize = 8
Const BlockSize = DCTSize * DCTSize
Dim pByte0() As Byte, pBytePtr0 As SAFEARRAY1D
Dim pByte1() As Byte, pBytePtr1 As SAFEARRAY1D
Dim LinePtr0 As Long
Dim LinePtr1 As Long
Dim X As Long, Y As Long
Dim I As Long, J As Long
Dim Idx As Long
Dim DCTData(0 To DCTSize - 1, 0 To DCTSize - 1) As Single
Dim DCTDataCr(0 To DCTSize - 1, 0 To DCTSize - 1) As Single
Dim BlockYs() As Long '为了简化代码设计，先将所有的Y分量提取出来
Dim cxBlock As Long, cyBlock As Long '水平/垂直方向块的数目
Dim cHy As Long, cVy As Long 'Y分量水平/垂直采样数
Dim MCU_Y As Long '一个MCU块中Y块的数目
Dim MaxX As Long, MaxY As Long '最大X/Y
Dim MaxI As Long
Dim Yx0 As Long, Yy0 As Long 'Y分量的X/Y坐标
MakePoint VarPtrArray(pByte0), pBytePtr0, 1
MakePoint VarPtrArray(pByte1), pBytePtr1, 1
With MyImage
'-- 提取Y分量
.CurItem = 1 'Y
.CurType = 0 '亮度
MaxX = .Width - 1
MaxY = .Height - 1
If (.Flags And JIC_Gray) = 0 Then '如果是彩色图
'(n+7)\8是进一法舍入数字
cxBlock = (.Width + 7) \ 8
cyBlock = (.Height + 7) \ 8
cHy = IIf(.Flags And JIC_Hy2, 2, 1)
If .Flags And JIC_Hy2 Then '如果JIC_Hy2，则水平Y块必须是2的倍数（偶数）
If cxBlock And 1 Then '表示cxBlock是奇数
cxBlock = cxBlock + 1
End If
End If
cVy = IIf(.Flags And JIC_Vy2, 2, 1)
If .Flags And JIC_Vy2 Then '如果JIC_Vy2，则垂直Y块必须是2的倍数（偶数）
If cyBlock And 1 Then '表示cyBlock是奇数
cyBlock = cyBlock + 1
End If
End If
MCU_Y = cHy * cVy
ReDim BlockYs(0 To BlockSize * cxBlock * cyBlock - 1)
End If
For Y = 0 To MaxY Step 8
'为了减少垂直方向判断
MaxI = MaxY - Y
If MaxI > 7 Then MaxI = 7
'此时y0代表当前Y块的起始索引
Yy0 = (Y \ DCTSize) * cxBlock
For X = 0 To MaxX Step 8
'-- 得到分量值
LinePtr0 = lpBits + LineBytes * (BI.biHeight - 1 - Y) + ItemBytes * X
For I = 0 To MaxI 'Y
pBytePtr0.pvData = LinePtr0
For J = 0 To 7 'X
If (X Or J) <= MaxX Then
DCTData(J, I) = JPEGRGB2YCbCr(0, 0) * pByte0(2) + JPEGRGB2YCbCr(1, 0) * pByte0(1) + JPEGRGB2YCbCr(2, 0) * pByte0(0) + JPEGRGB2YCbCrAdd(0)
Else
DCTData(J, I) = 0!
End If
pBytePtr0.pvData = pBytePtr0.pvData + ItemBytes
Next J
LinePtr0 = LinePtr0 - LineBytes
Next I
'-- 清零边角数据（由于存在DCT，所以必须放在内循环）
If MaxI < 7 Then
ZeroMemory DCTData(0, MaxI + 1), (7 - MaxI) * DCTSize * 4
End If
'-- DCT变换
Call JPEG_FDCT(VarPtr(DCTData(0, 0)))
'-- 之字型排列&量化
For J = 0 To 63
Idx = ZigZagPos(J)
'.Block(J) = DCTData(LoWord(Idx), HiWord(Idx)) \ DefDQT(J, 0)
.Block(J) = DCTData(Idx And &HF, Idx \ &H10000) \ .DQT(J, .CurType)
Next J
If .Flags And JIC_Gray Then '灰度图
Call JPEGWriteBlock(MyImage)
Else '彩色图
CopyMemory BlockYs((Yy0 + X \ DCTSize) * BlockSize), .Block(0), BlockSize * 4&
End If
Next X
Next Y
If (.Flags And JIC_Gray) = 0 Then '彩色图
'水平采样
If .Flags And JIC_Hy2 Then '水平方向缩小为原来的1/2
LinePtr0 = lpBits '此时不必考虑DIB逆序问题
For Y = 0 To MaxY
pBytePtr0.pvData = LinePtr0
pBytePtr1.pvData = LinePtr0
For X = 0 To MaxX - 1 Step 2
pByte1(0) = (CLng(pByte0(0)) + pByte0(ItemBytes + 0)) \ 2
pByte1(1) = (CLng(pByte0(1)) + pByte0(ItemBytes + 1)) \ 2
pByte1(2) = (CLng(pByte0(2)) + pByte0(ItemBytes + 2)) \ 2
pBytePtr0.pvData = pBytePtr0.pvData + ItemBytes + ItemBytes
pBytePtr1.pvData = pBytePtr1.pvData + ItemBytes
Next X
'最后一个
If (MaxX And 1) = 0 Then 'MaxX为偶数，Width为奇数
pByte1(0) = pByte0(0)
pByte1(1) = pByte0(1)
pByte1(2) = pByte0(2)
pBytePtr0.pvData = pBytePtr0.pvData + ItemBytes
pBytePtr1.pvData = pBytePtr1.pvData + ItemBytes
End If
''其他数据清零
'ZeroMemory ByVal CLng(pBytePtr1.pvData), LineBytes - (pBytePtr1.pvData - LinePtr0)
'指向下一行
LinePtr0 = LinePtr0 + LineBytes
Next Y
MaxX = MaxX \ 2 '(MaxX + 1 + 1) \ 2 - 1
End If
'垂直采样
If .Flags And JIC_Vy2 Then '垂直方向缩小为原来的1/2
LinePtr0 = lpBits + LineBytes * (BI.biHeight - 1)
LinePtr1 = LinePtr0
For Y = 0 To MaxY - 1 Step 2
pBytePtr0.pvData = LinePtr0 - LineBytes '故意上移一行，好在内循环用“+ LineBytes”寻址
pBytePtr1.pvData = LinePtr1
For X = 0 To MaxX
pByte1(0) = (CLng(pByte0(0)) + pByte0(0 + LineBytes)) \ 2
pByte1(1) = (CLng(pByte0(1)) + pByte0(1 + LineBytes)) \ 2
pByte1(2) = (CLng(pByte0(2)) + pByte0(2 + LineBytes)) \ 2
pBytePtr0.pvData = pBytePtr0.pvData + ItemBytes
pBytePtr1.pvData = pBytePtr1.pvData + ItemBytes
Next X
LinePtr0 = LinePtr0 - LineBytes - LineBytes
LinePtr1 = LinePtr1 - LineBytes
Next Y
'最后一行
If (MaxY And 1) = 0 Then 'MaxY为偶数，Height为奇数
CopyMemory ByVal CLng(lpBits + LineBytes * (BI.biHeight - 1 - MaxY \ 2)), ByVal CLng(lpBits), MaxX * ItemBytes
End If
''其他数据清0
'ZeroMemory ByVal CLng(lpBits), ((MaxY + 1) \ 2) * LineBytes
MaxY = MaxY \ 2 '(MaxY + 1 + 1) \ 2 - 1
End If
'写图像数据
For Y = 0 To MaxY Step DCTSize
'为了减少垂直方向判断
MaxI = MaxY - Y
If MaxI > 7 Then MaxI = 7
'此时y0代表当前Y坐标
Yy0 = (Y \ DCTSize) * cVy
For X = 0 To MaxX Step DCTSize
'-- 得到分量值
LinePtr0 = lpBits + LineBytes * (BI.biHeight - 1 - Y) + ItemBytes * X
For I = 0 To MaxI 'Y
pBytePtr0.pvData = LinePtr0
For J = 0 To 7 'X
If (X Or J) <= MaxX Then
DCTData(J, I) = JPEGRGB2YCbCr(0, 1) * pByte0(2) + JPEGRGB2YCbCr(1, 1) * pByte0(1) + JPEGRGB2YCbCr(2, 1) * pByte0(0) + JPEGRGB2YCbCrAdd(1)
DCTDataCr(J, I) = JPEGRGB2YCbCr(0, 2) * pByte0(2) + JPEGRGB2YCbCr(1, 2) * pByte0(1) + JPEGRGB2YCbCr(2, 2) * pByte0(0) + JPEGRGB2YCbCrAdd(2)
Else
DCTData(J, I) = 0!
DCTDataCr(J, I) = 0!
End If
pBytePtr0.pvData = pBytePtr0.pvData + ItemBytes
Next J
LinePtr0 = LinePtr0 - LineBytes
Next I
'-- 清零边角数据（由于存在DCT，所以必须放在内循环）
If MaxI < 7 Then
ZeroMemory DCTData(0, MaxI + 1), (7 - MaxI) * DCTSize * 4
ZeroMemory DCTDataCr(0, MaxI + 1), (7 - MaxI) * DCTSize * 4
End If
'-- 写亮度块
Yx0 = (X \ DCTSize) * cHy
For I = 0 To MCU_Y - 1
.CurItem = 1 'Y
.CurType = 0 '亮度
'复制块
CopyMemory .Block(0), BlockYs(((Yy0 + (I \ cHy)) * cxBlock + (Yx0 + (I Mod cHy))) * BlockSize), BlockSize * 4
'输出块
Call JPEGWriteBlock(MyImage)
Next I
'-- 写色度块
For I = 2 To 3
.CurItem = I 'Cb/Cr
.CurType = 1 '色度
'DCT变换
Call JPEG_FDCT(VarPtr(DCTData(0, 0)))
'之字型排列&量化
For J = 0 To 63
Idx = ZigZagPos(J)
'.Block(J) = DCTData(LoWord(Idx), HiWord(Idx)) \ DefDQT(J, .CurType)
.Block(J) = DCTData(Idx And &HF, Idx \ &H10000) \ .DQT(J, .CurType)
Next J
'输出块
Call JPEGWriteBlock(MyImage)
'指向下一色度块
If I = 2 Then 'Cb
CopyMemory DCTData(0, 0), DCTDataCr(0, 0), BlockSize * 4
End If
Next I
Next X
Next Y
End If
End With
FreePoint VarPtrArray(pByte0)
FreePoint VarPtrArray(pByte1)
'== 结束编码
JPEGSave = JPEGEncodeEnd(MyImage)
End Function
'准备开始编码
Private Function JPEGEncodeBegin(ByRef MyImage As JPEGImage, ByRef FileName As String) As Boolean
Dim TempBytes() As Byte
Dim TempByte As Byte
Dim TempWord As Integer
Dim I As Long, J As Long
With MyImage
'检查参数
If .Flags And JIC_Gray Then .Flags = .Flags And Not (JIC_Hy2 Or JIC_Vy2)
If (.Flags And JIC_QualityMask) > 100 Then .Flags = (.Flags And (Not JIC_QualityMask)) Or 100
If .Flags And JIC_AutoDHT Then Exit Function '暂时不支持自动生成最优化Huffman表（算法比较复杂，程序的结构就写的比较乱）
'打开文件
If ChkFileWrite(FileName) = False Then Exit Function
.hFile = FreeFile()
Open FileName For Binary As .hFile
'SOI
Put .hFile, , JPEGCode
Put .hFile, , JPEG_SOI
'APP0
Put .hFile, , JPEGCode
Put .hFile, , CByte(JPEG_APP + 0)
WordBig(TempWord) = 16
Put .hFile, , TempWord '长度
ReDim TempBytes(1 To 5)
CopyMemory TempBytes(1), ByVal "JFIF", 5 'byval对String会自动转换成LPSTR
Put .hFile, , TempBytes 'JFIF
WordBig(TempWord) = &H101
Put .hFile, , TempWord '版本
TempByte = 0
Put .hFile, , TempByte '分辨率单位
WordBig(TempWord) = 1
Put .hFile, , TempWord 'X分辨率
WordBig(TempWord) = 1
Put .hFile, , TempWord 'Y分辨率
TempByte = 0
Put .hFile, , TempByte '缩略图宽
TempByte = 0
Put .hFile, , TempByte '缩略图高
'SOF0
Put .hFile, , JPEGCode
Put .hFile, , CByte(JPEG_SOF + 0) '基线方式
.Items = IIf(.Flags And JIC_Gray, 1, 3)
WordBig(TempWord) = 8 + 3 * .Items '分量数
Put .hFile, , TempWord '长度
TempByte = 8
Put .hFile, , TempByte '精度
WordBig(TempWord) = .Height
Put .hFile, , TempWord '高度（先写高度再写宽度，可很多书写反了）
WordBig(TempWord) = .Width
Put .hFile, , TempWord '宽度
TempByte = .Items
Put .hFile, , TempByte '颜色分量数
For I = 1 To .Items
.OldDC(I) = 0
TempByte = I
Put .hFile, , TempByte '颜色分量编号
If I = 1 And .Items = 3 Then
TempByte = 0
TempByte = TempByte Or IIf(.Flags And JIC_Hy2, &H20, &H10)
TempByte = TempByte Or IIf(.Flags And JIC_Vy2, &H2, &H1)
Else
TempByte = &H11
End If
Put .hFile, , TempByte '水平/垂直采样
TempByte = IIf(I = 1, 0, 1)
Put .hFile, , TempByte '量化表
Next I
'DQT
Put .hFile, , JPEGCode
Put .hFile, , JPEG_DQT
.DQTItems = IIf(.Items = 1, 1, 2)
WordBig(TempWord) = 2 + &H41 * .DQTItems
Put .hFile, , TempWord '长度
'Put .hFile, , DefDQTData 'DQT数据
Dim Diff As Long '由于是在0%量化表与全精量化表中间做线性插值，算反的更快一些（1是常数，编译时按立即数处理）
'Quality = .Flags And JIC_QualityMask
Diff = 100 - (.Flags And JIC_QualityMask)
ReDim TempBytes(0 To 63)
For I = 0 To .DQTItems - 1
TempByte = I
Put .hFile, , TempByte '量化表编号
For J = 0 To 63
.DQT(J, I) = 1 + ((DefDQT(J, I) - 1) * Diff + 50) \ 100 '+50是为了四舍五入
TempBytes(J) = .DQT(J, I)
Next J
Put .hFile, , TempBytes '量化表
Next I
If (.Flags And JIC_AutoDHT) = 0 Then
'DHT
Put .hFile, , JPEGCode
Put .hFile, , JPEG_DHT
WordBig(TempWord) = 2 + UBound(DefDHTData) + 1
Put .hFile, , TempWord '长度
Put .hFile, , DefDHTData 'DHT数据
'SOS
Put .hFile, , JPEGCode
Put .hFile, , JPEG_SOS
WordBig(TempWord) = 3 + 2 * .Items + 3 '分量数
Put .hFile, , TempWord '长度
TempByte = .Items
Put .hFile, , TempByte '颜色分量数
For I = 1 To .Items
TempByte = I
Put .hFile, , TempByte '颜色分量编号
TempByte = IIf(I = 1, &H0, &H11)
Put .hFile, , TempByte 'DC/AC Huffman表
Next I
TempByte = 0
Put .hFile, , TempByte 'Ss:起始频谱选择
TempByte = 63
Put .hFile, , TempByte 'Se:终止频谱选择
TempByte = 0
Put .hFile, , TempByte '(Ah,Al)
End If
End With
JPEGEncodeBegin = True
End Function
'准备结束编码
Private Function JPEGEncodeEnd(ByRef MyImage As JPEGImage) As Boolean
With MyImage
If .Flags And JIC_AutoDHT Then
'
End If
If .BitUsed Then '如果存在还未封装成字节的位
Call JPEGOutBits(MyImage, 0, 8 - .BitUsed)
End If
'== 编码结束
'EOI
Put .hFile, , JPEGCode
Put .hFile, , JPEG_EOI
Close .hFile
End With
JPEGEncodeEnd = True
End Function
Private Sub JPEGWriteBlock(ByRef MyImage As JPEGImage)
Dim DiffDC As Long
Dim cnt As Long
Dim I As Long
With MyImage
'-- 设置type
.CurType = IIf(.CurItem = 1, 0, 1)
'-- 对DC进行编码
.CurDCAC = 0
DiffDC = .Block(0) - .OldDC(.CurItem)
.OldDC(.CurItem) = .Block(0)
Call JPEGOutDC(MyImage, DiffDC)
'-- 对AC进行编码
.CurDCAC = 1
cnt = 0
For I = 1 To 63
If .Block(I) = 0 Then
cnt = cnt + 1
Else
Do While cnt > 15
'Stop
'输出ZRL标记
Call JPEGOutAC(MyImage, &HF, 0)
cnt = cnt - 16
Loop
'输出编码
Call JPEGOutAC(MyImage, cnt, .Block(I))
cnt = 0
End If
Next I
If cnt Then '最后一个系数是0时，肯定可以EOB
'输出EOB标记
Call JPEGOutAC(MyImage, 0, 0)
End If
End With
End Sub
'输出DC
Private Sub JPEGOutDC(ByRef MyImage As JPEGImage, ByVal Value As Long)
Dim ValueBits As Long
Dim DataSign As Boolean
'ValueBits = ChkNumBitsAuto(Value)
DataSign = Value < 0
If DataSign Then Value = -Value
Select Case Value
Case 0: ValueBits = 0
Case Is <= 1: ValueBits = 1
Case Is <= 3: ValueBits = 2
Case Is <= 7: ValueBits = 3
Case Is <= 15: ValueBits = 4
Case Is <= 31: ValueBits = 5
Case Is <= 63: ValueBits = 6
Case Is <= 127: ValueBits = 7
Case Is <= 255: ValueBits = 8
Case Is <= 511: ValueBits = 9
Case Is <= 1023: ValueBits = 10
Case Is <= 2047: ValueBits = 11
'Case Else: Stop '没有这么大的数
End Select
If DataSign Then Value = Value Xor BitsMask(ValueBits)
With MyImage
If (.Flags And JIC_AutoDHT) = 0 Then '使用默认Huffman表
Call JPEGOutBits(MyImage, DefHCodeDC(ValueBits, .CurType), DefHCodeSizeDC(ValueBits, .CurType))
If ValueBits Then Call JPEGOutBits(MyImage, Value, ValueBits)
Else '最优化Huffman表
End If
End With
End Sub
'输出AC
Private Sub JPEGOutAC(ByRef MyImage As JPEGImage, ByVal ZeroCount As Long, ByVal Value As Long)
Dim TempCode As Long
Dim ValueBits As Long
Dim DataSign As Boolean
'ValueBits = ChkNumBitsAuto(Value)
DataSign = Value < 0
If DataSign Then Value = -Value
Select Case Value
Case 0: ValueBits = 0
Case Is <= 1: ValueBits = 1
Case Is <= 3: ValueBits = 2
Case Is <= 7: ValueBits = 3
Case Is <= 15: ValueBits = 4
Case Is <= 31: ValueBits = 5
Case Is <= 63: ValueBits = 6
Case Is <= 127: ValueBits = 7
Case Is <= 255: ValueBits = 8
Case Is <= 511: ValueBits = 9
Case Is <= 1023: ValueBits = 10
Case Is <= 2047: ValueBits = 11
'Case Else: Stop '没有这么大的数
End Select
If DataSign Then Value = Value Xor BitsMask(ValueBits)
TempCode = ZeroCount * &H10 Or ValueBits
With MyImage
If (.Flags And JIC_AutoDHT) = 0 Then '使用默认Huffman表
Call JPEGOutBits(MyImage, DefHCodeAC(TempCode, .CurType), DefHCodeSizeAC(TempCode, .CurType))
'在默认AC表中无对应值（用断言检查较好）
'If DefHCodeSizeAC(TempCode, .CurType) = 0 Then Stop
Debug.Assert DefHCodeSizeAC(TempCode, .CurType)
If ValueBits Then Call JPEGOutBits(MyImage, Value, ValueBits)
Else '最优化Huffman表
End If
End With
End Sub
'输出位流
Private Sub JPEGOutBits(ByRef MyImage As JPEGImage, ByVal Value As Long, ByVal ValueBits As Long)
Dim TempByte As Byte
With MyImage
'位流接在原数据的后面
.BitBuff = (.BitBuff * BitPosMask(ValueBits)) Or Value 'And BitsMask(ValueBits))
.BitUsed = .BitUsed + ValueBits
Do While .BitUsed >= 8
.BitUsed = .BitUsed - 8
TempByte = .BitBuff \ BitPosMask(.BitUsed) 'TempByte=.BitBuff>>.BitUsed
.BitBuff = .BitBuff And BitsMask(.BitUsed)
Put .hFile, , TempByte
If TempByte = &HFF Then '细节问题(1)
TempByte = 0
Put .hFile, , TempByte
End If
Loop
End With
End Sub