如果让Access及VB6或VBA 的Form2.0支持PNG图片

如果让Access及VB6或VBA 的Form2.0支持PNG图片

1.Access 2007之后的2010 2013 2016 2019等版本已经支持了png格式

只要 新建文件格式为accdb即可

2.VB6 和VBA的Form2.0 则需要使用Gdi+ 用代码来读png再赋给控件

可以参考这个601居士作者相关的代码

纯VB6代码载入并显示 PNG 图片
纯VB6代码载入并显示 PNG 图片
窗体代码：
'***********************************************************************
'*                                                                     *
'*    原作者：601居士，向原作者致敬！                                  *
'*                                                                     *
'*    原作者博客地址：http://blog.sina.com.cn/u/2968360967             *
'*                                                                     *
'*    本代码改编自：                                                   *
'*                                                                     *
'*    http://blog.sina.com.cn/s/blog_b0ed98070102zarg.html             *
'*                                                                     *
'*    本代码改编时间：2019年5月                                        *
'*                                                                     *
'*    本代码功能是用纯VB6代码载入并显示 PNG 图片                       *
'*                                                                     *
'*    使用方法：运行本软件，出现在屏幕左上角，拖拽PNG图片到窗体即可    *
'*                                                                     *
'*    窗体无标题栏，窗体可拖动，右键点击窗体退出，双击窗体显示帮助     *
'*                                                                     *
'***********************************************************************
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Dim X0!, Y0!
Dim pngClass As New LoadPNG
Private Sub Form_DblClick()
s = s & "原作者：601居士，向原作者致敬！" & vbCrLf & vbCrLf
s = s & "原作者博客地址：http://blog.sina.com.cn/u/2968360967" & vbCrLf & vbCrLf
s = s & "本代码改编自：" & vbCrLf & vbCrLf
s = s & "http://blog.sina.com.cn/s/blog_b0ed98070102zarg.html" & vbCrLf & vbCrLf
s = s & "本代码改编时间：2019年5月" & vbCrLf & vbCrLf
s = s & "本代码功能是用纯VB6代码载入并显示 PNG 图片" & vbCrLf & vbCrLf
s = s & "使用方法：运行本软件，出现在屏幕左上角，拖拽PNG图片到窗体即可" & vbCrLf & vbCrLf
s = s & "窗体无标题栏，窗体可拖动，右键点击窗体退出，双击窗体显示帮助"
MsgBox s
End Sub

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo over 'Picture1.Cls 'Text1 = ""
pngClass.OpenPNG Data.Files(1), Form1, , , 1  '参数：(前2个参数必需，后3个参数可选)：1-文件名，2-显示图像的对象，3、4-显示坐标，5-放大倍数
Me.Caption = Mid(Data.Files(1), InStrRev(Data.Files(1), "") + 1)
If Len(pngClass.Text) Then Text1 = pngClass.Text
over:
End Sub
Private Sub Form_Load()
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then End
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
X0 = x
Y0 = y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Me.Left = Me.Left + x - X0
Me.Top = Me.Top + y - Y0
End If
End Sub


类模块代码：
'****************************************************************************
'**
'*原作者：601居士，向原作者致敬！ *
'**
'*原作者博客地址：http://blog.sina.com.cn/u/2968360967*
'**
'*本代码改编自：*
'**
'*http://blog.sina.com.cn/s/blog_b0ed98070102zarg.html*
'**
'*本代码改编时间：2019年5月 *
'**
'*本代码功能是用纯VB6代码载入并显示 PNG 图片*
'**
'*使用方法：运行本软件，出现在屏幕左上角，拖拽PNG图片到窗体即可 *
'**
'*窗体无标题栏，窗体可拖动，右键点击窗体退出，双击窗体显示帮助*
'**
'****************************************************************************
Private Type RGBTriple 'PNG图片调色板结构
Red As Byte '红色分量
Green As Byte '绿色分量
Blue As Byte '蓝色分量
End Type
 
Private Type BITMAPINFOHEADER 'BMP位图的信息头结构
Size As Long '信息头长度（固定为40）
Width As Long '图像宽度
Height As Long '图像高度
Planes As Integer '位面板数
BitCount As Integer '每像素所占位数
Compression As Long '压缩类型
SizeImage As Long '图像数据长度
XPelsPerMeter As Long '设备水平分辨率
YPelsPerMeter As Long '设备垂直分辩率
ClrUsed As Long '有效颜色数，O表示全要使用
ClrImportant As Long '重要的颜色索引个数，0表示所有颜色均重要
End Type
 
Private Type RGBQUAD 'BMP位图调色板结构
rgbBlue As Byte '蓝色分量
rgbGreen As Byte '绿色分量
rgbRed As Byte '红色分量
rgbReserved As Byte '保留的
End Type
 
Private Type BITMAPINFO_1 '单色BMP位图
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
 
Private Type BITMAPINFO_2
bmiHeader As BITMAPINFOHEADER
bmiColors(3) As RGBQUAD
End Type
 
Private Type BITMAPINFO_4 '16色BMP位图
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
 
Private Type BITMAPINFO_8 '256色BMP位图
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
 
Private Type BITMAPINFO_24 '24位真彩BMP位图
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
 
Private Type BITMAPINFO_24a '24位真彩PNG图片
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBTriple
End Type
 
Private Type IHDR 'PNG文件头（IHDR）中的数据域结构，固定为13
Width As Long '图像宽度
Height As Long '图像高度
BitDepth As Byte '颜色深度
ColorType As Byte '颜色类型
Compression As Byte '压缩方法
Filter As Byte '滤波器方法
Interlacing As Byte '隔行扫描方法
End Type
 
Private Type CodesType
Lenght() As Long
code() As Long
End Type
 
 
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateDIBitmap_1 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_1, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_2 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_2, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_4 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_4, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_8 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_8, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_24 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_24, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_24a Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_24a, ByVal wUsage As Long) As Long
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 GetDIBits Lib "gdi32" (ByVal aHDC 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 Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination As Any, ByVal length As Long, ByVal Fill As Byte)
 
Private bm1 As BITMAPINFO_1
Private bm2 As BITMAPINFO_2
Private bm4 As BITMAPINFO_4
Private bm8 As BITMAPINFO_8
Private bm24 As BITMAPINFO_24
Private bm24a As BITMAPINFO_24a
 
Dim TempLit As CodesType, TempDist As CodesType, Dist As CodesType
Dim LC As CodesType, dc As CodesType, LitLen As CodesType
Dim OutStream() As Byte, InStream() As Byte, Pow2(16) As Long, BitMask(16) As Long, LenOrder(18) As Long
Dim hBmp As Long, OutPos As Long, Inpos As Long, ByteBuff As Long, BitNum As Long
Dim MinLLenght As Long, MaxLLenght As Long, MinDLenght As Long, MaxDLenght As Long
Dim BPPprivat As Long, Colorused As Long
Dim IDATData() As Byte '图像数据
Dim IdataLen As Long '图像数据长度
Dim Palettenbyte() As Byte '调色板数据
Dim IsStaticBuild As Boolean '创建静态结构标记
Dim m_Bgx As Long '用户输入的 X 坐标
Dim m_Bgy As Long '用户输入的 Y 坐标
Dim m_multiple As Long '用户输入的图像放大倍数
Dim m_PicBox As Object '用户输入的显示图像对象
'只读属性值
Dim m_width As Long '图像宽
Dim m_height As Long '图像高
Dim m_bitdepht As Long '颜色深度
Dim m_colortype As Long '颜色类型
Dim m_text As String '文本信息
 
'方法(前2个参数必需，后3个参数可选)：1-文件名，2-显示图像的对象，3、4-显示坐标，5-放大倍数
Public Sub OpenPNG(Filename As String, ByVal PicBox As Object, Optional x As Long = 0, Optional y As Long = 0, Optional Multiple As Single = 1)
On Error GoTo over
Dim a() As Byte
Dim b(0) As Long
Dim Stand As Long '当前读入的字节位置
Dim Ende As Boolean '数据读完标记
Dim Filenumber As Long
Dim Signature(7) As Byte
Dim Test As Long
Dim Ltge As Long
Dim ChunkName As String * 4 '数据块符号
Dim ChunkInhalt() As Byte '数据域
Dim CRC32Inhalt As Long 'CRC校验码
ReDim IDATData(0)
ReDim a(FileLen(Filename) - 1)
Set m_PicBox = PicBox: m_Bgx = x: m_Bgy = y: BPPprivat = 0: IdataLen = 0: If Multiple > 0 Then m_multiple = Multiple
Filenumber = FreeFile
Open Filename For Binary As Filenumber
Get Filenumber, , a
Test = IsValidSignature(a) '读出前8个字节
If Not Test Then '如果不是PNG标记退出
Close Filenumber
Exit Sub
End If
Stand = 8
Do While Ende = False
CopyMemory Ltge, a(Stand), 4 '读入长整形4个字节，这是数据块的数据域长度
Stand = Stand + 4
SwapBytesLong Ltge
CopyMemory ByVal ChunkName, a(Stand), 4 '读入4个字节字符，这是数据块符号
Stand = Stand + 4 ' Seek(Filenumber)'获取当前读入的字节位置
If Ltge > 0 Then ReDim ChunkInhalt(Ltge - 1) '如果不是结束块，定义数据域长度
If Stand + Ltge + 1 > LOF(Filenumber) Then Stop: Exit Sub '如果当前位置+数据域长度>文件长度，发生错误
CopyMemory ChunkInhalt(0), a(Stand), Ltge '读入数据域
Stand = Stand + Ltge
CopyMemory CRC32Inhalt, a(Stand), 4 '读入CRC校验码
Stand = Stand + 4
Select Case ChunkName
Case "IHDR" '文件头数据块
ReadIHDR ChunkInhalt
Case "PLTE" '调色板数据块
ReDim Palettenbyte(UBound(ChunkInhalt))
CopyMemory Palettenbyte(0), ChunkInhalt(0), UBound(ChunkInhalt) + 1
Case "IDAT" '图像数据块
ReDim Preserve IDATData(IdataLen + UBound(ChunkInhalt))
CopyMemory IDATData(IdataLen), ChunkInhalt(0), UBound(ChunkInhalt) + 1
IdataLen = UBound(IDATData) + 1
Case "IEND" '结束数据块
Ende = True
Case "tEXt" '文本信息数据块
m_text = StrConv(ChunkInhalt, vbUnicode)
End Select
Loop
PicBox.Width = m_width * 15
PicBox.Height = m_height * 15
Close Filenumber
If IdataLen > 0 Then MakePicture '处理图形
over:
End Sub
Private Function IsValidSignature(Signature() As Byte) As Boolean '判断是否PNG标记
If Signature(0) <> 137 Then Exit Function
If Signature(1) <> 80 Then Exit Function
If Signature(2) <> 78 Then Exit Function
If Signature(3) <> 71 Then Exit Function
If Signature(4) <> 13 Then Exit Function
If Signature(5) <> 10 Then Exit Function
If Signature(6) <> 26 Then Exit Function
If Signature(7) <> 10 Then Exit Function
IsValidSignature = True
End Function
 
Private Sub SwapBytesLong(ByteValue As Long) '转化长整形低位在前高位在后的数据
Dim Tergabe As Long, i As Long
For i = 0 To 3
CopyMemory ByVal VarPtr(Tergabe) + i, ByVal VarPtr(ByteValue) + (3 - i), 1
Next i
ByteValue = Tergabe
End Sub
Private Sub ReadIHDR(Bytefeld() As Byte) '处理文件头数据块
Dim Header As IHDR
CopyMemory ByVal VarPtr(Header), Bytefeld(0), 13
SwapBytesLong Header.Width
SwapBytesLong Header.Height
m_width = Header.Width '图像宽
m_height = Header.Height '图像高
m_bitdepht = Header.BitDepth '颜色深度
m_colortype = Header.ColorType '颜色类型
End Sub
 
Private Sub MakePicture() '处理图形
Dim Buffer() As Byte '缓冲区
Dim BitCount As Integer, Bitdepht As Long, Drehen As Integer, DataSize As Long
Drehen = 1
DataSize = DataPerRow * m_height '非隔行扫描方法
ReDim Buffer(UBound(IDATData) - 2)
CopyMemory Buffer(0), IDATData(2), UBound(IDATData) - 1
Decompress Buffer, DataSize '使用压缩
Buffer = DeFilter(Buffer)
Drehen = 1
BitCount = m_bitdepht '颜色深度
Select Case m_colortype '根据颜色类型处理
Case 0 '灰度图像
Select Case m_bitdepht '根据颜色深度处理
Case 16
Conv16To8 Buffer
InitColorTable_Grey 8
BitCount = 8
BPPprivat = 8
Case 8, 4, 1
 BitCount = m_bitdepht
 InitColorTable_Grey m_bitdepht, False
 Align32 BitCount, Buffer
Case 2
InitColorTable_Grey 2
Pal2To8 Buffer, DataPerRow
BitCount = 8
BPPprivat = 8
End Select
Case 2 '真彩图像
If m_bitdepht = 16 Then Conv16To8 Buffer
BitCount = 24
BPPprivat = 24
ReverseRGB Buffer
Drehen = 1
BPPprivat = 8
Align32 BitCount, Buffer
BPPprivat = 24
Case 3 '索引彩图
Select Case m_bitdepht
Case 8, 4, 1
 BitCount = m_bitdepht
 If BitCount >= 8 Then Align32 BitCount, Buffer
Case 2
 BitCount = 8
 BPPprivat = 8
 Align32 BitCount, Buffer
 End Select
Case 4 '带α通道数据的灰度图像
If m_bitdepht = 16 Then Conv16To8 Buffer
GrayAToRGBA Buffer
BPPprivat = 32
BitCount = 32
MirrorData Buffer, LineBytes(BitCount)
Drehen = 0
MakeAlpha Buffer
BPPprivat = 24
BitCount = 24
Case 6 '带α通道数据的真彩色图像
If m_bitdepht = 16 Then Conv16To8 Buffer
BitCount = 32
BPPprivat = 32
ReverseRGBA Buffer
MirrorData Buffer, LineBytes(BitCount)
Drehen = 0
MakeAlpha Buffer
BPPprivat = 24
BitCount = 24
End Select
If Not (((m_colortype = 3) And (BitCount = 32)) Or (m_bitdepht = 2)) Then If m_bitdepht = 16 Then Bitdepht = 16
Select Case BitCount '根据颜色深度处理
Case 1
Align32 BitCount, Buffer
Select Case m_colortype
Case 3: InitColorTable_1Palette Palettenbyte
Case Else: InitColorTable_1
End Select
CreateBitmap_1 Buffer, True, Colorused
DrawBitmap
Case 2
Align32 BitCount, Buffer
Case 4
Align32 BitCount, Buffer
Select Case m_colortype
Case 0
Case Else
InitColorTable_4 Palettenbyte
End Select
CreateBitmap_4 Buffer, True, Colorused
DrawBitmap
Case 8
Select Case m_colortype
Case 0, 4
Case Else
InitColorTable_8 Palettenbyte
End Select
Drehen = 1
CreateBitmap_8 Buffer, Drehen, Colorused
DrawBitmap
Case 24
CreateBitmap_24 Buffer, Drehen, 1
DrawBitmap
Case 32
CreateBitmap_24 Buffer, Drehen
DrawBitmap
End Select
End Sub
 
'解压缩
Private Function Decompress(ByteArray() As Byte, UncompressedSize As Long, Optional ZIP64 As Boolean = False) As Long
Dim IsLastBlock As Boolean, CompType As Long, Char As Long, Nubits As Long
Dim L1 As Long, L2 As Long, x As Long, k As Integer
UncompressedSize = UncompressedSize + 100
InStream = ByteArray
Call Init_Decompress(UncompressedSize)
Do
IsLastBlock = GetBits(1)
CompType = GetBits(2)
If CompType = 0 Then
If Inpos + 4 > UBound(InStream) Then Decompress = -1: Exit Do
Do While BitNum >= 8
Inpos = Inpos - 1
BitNum = BitNum - 8
Loop
CopyMemory L1, InStream(Inpos), 2&
CopyMemory L2, InStream(Inpos + 2), 2&
Inpos = Inpos + 4
If L1 - (Not (L2) And &HFFFF&) Then Decompress = -2
If Inpos + L1 - 1 > UBound(InStream) Then Decompress = -1: Exit Do
If OutPos + L1 - 1 > UBound(OutStream) Then Decompress = -1: Exit Do
CopyMemory OutStream(OutPos), InStream(Inpos), L1
OutPos = OutPos + L1
Inpos = Inpos + L1
ByteBuff = 0
BitNum = 0
ElseIf CompType = 3 Then
Decompress = -1
Exit Do
Else
If CompType = 1 Then
If Create_Static_Tree <> 0 Then
MsgBox "Error in tree creation (Static)"
Exit Function
End If
Else
If Create_Dynamic_Tree <> 0 Then
MsgBox "Error in tree creation (Static)"
Exit Function
End If
End If
Do
NeedBits MaxLLenght
Nubits = MinLLenght
Do While LitLen.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = LitLen.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
If Char < 256 Then OutStream(OutPos) = Char OutPos = OutPos + 1 ElseIf Char > 256 Then
Char = Char - 257
L1 = LC.code(Char) + GetBits(LC.Lenght(Char))
If (L1 = 258) And ZIP64 Then L1 = GetBits(16) + 3
NeedBits MaxDLenght
Nubits = MinDLenght
Do While Dist.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = Dist.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
L2 = dc.code(Char) + GetBits(dc.Lenght(Char))
For x = 1 To L1
If OutPos > UncompressedSize Then
OutPos = UncompressedSize
GoTo Stop_Decompression
End If
OutStream(OutPos) = OutStream(OutPos - L2)
OutPos = OutPos + 1
Next x
End If
Loop While Char <> 256 'EOB
 
End If
Loop While Not IsLastBlock
Stop_Decompression:
If OutPos > 0 Then
ReDim Preserve OutStream(OutPos - 1)
Else
Erase OutStream
End If
Erase InStream, BitMask, Pow2, LC.code, LC.Lenght, dc.code, dc.Lenght
Erase Dist.code, Dist.Lenght, LenOrder, LitLen.code, LitLen.Lenght
ByteArray = OutStream
End Function
 
Private Function Create_Static_Tree() '创建静态结构
Dim x As Long, Lenght(287) As Long
If IsStaticBuild = False Then
For x = 0 To 143: Lenght(x) = 8: Next
For x = 144 To 255: Lenght(x) = 9: Next
For x = 256 To 279: Lenght(x) = 7: Next
For x = 280 To 287: Lenght(x) = 8: Next
If Create_Codes(TempLit, Lenght, 287, MaxLLenght, MinLLenght) <> 0 Then
Create_Static_Tree = -1
Exit Function
End If
For x = 0 To 31: Lenght(x) = 5: Next
Create_Static_Tree = Create_Codes(TempDist, Lenght, 31, MaxDLenght, MinDLenght)
IsStaticBuild = True
Else
MinLLenght = 7
MaxLLenght = 9
MinDLenght = 5
MaxDLenght = 5
End If
LitLen = TempLit: Dist = TempDist
End Function
 
Private Function Create_Dynamic_Tree() As Long '创建动态结构
Dim Lenght() As Long
Dim Bl_Tree As CodesType
Dim MinBL As Long, MaxBL As Long, NumLen As Long, Numdis As Long, NumCod As Long
Dim Char As Long, Nubits As Long, LN As Long, Pos As Long, x As Long
NumLen = GetBits(5) + 257
Numdis = GetBits(5) + 1
NumCod = GetBits(4) + 4
ReDim Lenght(18)
For x = 0 To NumCod - 1: Lenght(LenOrder(x)) = GetBits(3): Next
For x = NumCod To 18: Lenght(LenOrder(x)) = 0: Next
If Create_Codes(Bl_Tree, Lenght, 18, MaxBL, MinBL) <> 0 Then Create_Dynamic_Tree = -1: Exit Function
ReDim Lenght(NumLen + Numdis)
Pos = 0
Do While Pos < NumLen + Numdis NeedBits MaxBL Nubits = MinBL Do While Bl_Tree.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = Bl_Tree.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
If Char < 16 Then Lenght(Pos) = Char Pos = Pos + 1 Else If Char = 16 Then If Pos = 0 Then Create_Dynamic_Tree = -5: Exit Function LN = Lenght(Pos - 1) Char = 3 + GetBits(2) ElseIf Char = 17 Then Char = 3 + GetBits(3) LN = 0 Else Char = 11 + GetBits(7) LN = 0 End If If Pos + Char > NumLen + Numdis Then Create_Dynamic_Tree = -6: Exit Function
Do While Char > 0
Char = Char - 1
Lenght(Pos) = LN
Pos = Pos + 1
Loop
End If
Loop
If Create_Codes(LitLen, Lenght, NumLen - 1, MaxLLenght, MinLLenght) <> 0 Then
Create_Dynamic_Tree = -1
 Exit Function
End If
For x = 0 To Numdis: Lenght(x) = Lenght(x + NumLen): Next
Create_Dynamic_Tree = Create_Codes(Dist, Lenght, Numdis - 1, MaxDLenght, MinDLenght)
End Function

'创建编码
Private Function Create_Codes(tree As CodesType, Lenghts() As Long, NumCodes As Long, MaxBits As Long, Minbits As Long) As Long
Dim Bits(16) As Long
Dim next_code(16) As Long
Dim code As Long
Dim LN As Long
Dim x As Long
Minbits = 16
For x = 0 To NumCodes
Bits(Lenghts(x)) = Bits(Lenghts(x)) + 1
If Lenghts(x) > MaxBits Then MaxBits = Lenghts(x)
If Lenghts(x) < Minbits And Lenghts(x) > 0 Then Minbits = Lenghts(x)
Next
LN = 1
For x = 1 To MaxBits
LN = LN + LN
LN = LN - Bits(x)
If LN < 0 Then Create_Codes = LN: Exit Function Next Create_Codes = LN ReDim tree.code(2 ^ MaxBits - 1), tree.Lenght(2 ^ MaxBits - 1) code = 0 Bits(0) = 0 For x = 1 To MaxBits: code = (code + Bits(x - 1)) * 2: next_code(x) = code: Next For x = 0 To NumCodes LN = Lenghts(x) If LN <> 0 Then
code = Bit_Reverse(next_code(LN), LN)
tree.Lenght(code) = LN
tree.code(code) = x
next_code(LN) = next_code(LN) + 1
End If
Next
End Function
 
Private Function Bit_Reverse(ByVal Value As Long, ByVal Numbits As Long) '位反转
Do While Numbits > 0
Bit_Reverse = Bit_Reverse * 2 + (Value And 1)
Numbits = Numbits - 1
Value = Value \ 2
Loop
End Function
Private Sub Init_Decompress(UncompressedSize As Long) '解压缩
Dim Temp()
Dim x As Long
Erase LitLen.code, Dist.code, Dist.Lenght, LitLen.Lenght
ReDim OutStream(UncompressedSize)
ReDim LC.code(31), LC.Lenght(31), dc.code(31), dc.Lenght(31)
Temp() = Array(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15)
For x = 0 To UBound(Temp): LenOrder(x) = Temp(x): Next
Temp() = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258)
For x = 0 To UBound(Temp): LC.code(x) = Temp(x): Next
Temp() = Array(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0)
For x = 0 To UBound(Temp): LC.Lenght(x) = Temp(x): Next
Temp() = Array(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289, 16385, 24577, 32769, 49153)
For x = 0 To UBound(Temp): dc.code(x) = Temp(x): Next
Temp() = Array(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14)
For x = 0 To UBound(Temp): dc.Lenght(x) = Temp(x): Next
For x = 0 To 16: BitMask(x) = 2 ^ x - 1: Pow2(x) = 2 ^ x: Next
OutPos = 0: Inpos = 0: ByteBuff = 0: BitNum = 0
End Sub
Private Sub NeedBits(Numbits As Long)
While BitNum < Numbits If Inpos > UBound(InStream) Then Exit Sub
ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum))
BitNum = BitNum + 8
Inpos = Inpos + 1
Wend
End Sub
 
Private Sub DropBits(Numbits As Long)
ByteBuff = ByteBuff \ Pow2(Numbits)
BitNum = BitNum - Numbits
End Sub
Private Function GetBits(Numbits As Long) As Long
While BitNum < Numbits ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum)) BitNum = BitNum + 8 Inpos = Inpos + 1 Wend GetBits = ByteBuff And BitMask(Numbits) ByteBuff = ByteBuff \ Pow2(Numbits) BitNum = BitNum - Numbits End Function Private Function DeFilter(Dat() As Byte) As Byte() '脱去滤波器 Dim NewDat() As Byte, y As Long, iVal As Long Dim n As Long, StartByte As Long, DestByte As Long Dim BPRow As Long, x As Long, RowBytes() As Byte Dim PrevRowBytes() As Byte Dim i As Long iVal = Interval() BPRow = DataPerRow() ReDim NewDat(UBound(Dat) - m_height), PrevRowBytes(DataPerRow() - 2), RowBytes(DataPerRow() - 2) For y = 0 To m_height - 1 StartByte = BPRow * y DestByte = StartByte - y x = 0 CopyMemory RowBytes(0), Dat(StartByte + 1), BPRow - 1 Select Case Dat(StartByte) Case 0 Case 1: ReverseSub RowBytes, iVal Case 2: ReverseUp RowBytes, PrevRowBytes Case 3: ReverseAverage RowBytes, PrevRowBytes, iVal Case 4: ReversePaeth RowBytes, PrevRowBytes, iVal End Select CopyMemory NewDat(DestByte), RowBytes(0), BPRow - 1 PrevRowBytes = RowBytes Next y DeFilter = NewDat End Function Private Function BitsPerPixel() As Long Dim Bpp As Long Bpp = m_bitdepht If BPPprivat <> Bpp And BPPprivat <> 0 Then Bpp = BPPprivat
Select Case m_colortype
Case 0, 3: BitsPerPixel = Bpp
Case 2: BitsPerPixel = 3 * Bpp
Case 6: BitsPerPixel = 4 * Bpp
Case 4: BitsPerPixel = 2 * Bpp
End Select
End Function
 
Private Function DataPerRow() As Long
DataPerRow = (m_width * BitsPerPixel() + 7) \ 8 + 1
End Function
 
'反转平均值
Private Sub ReverseAverage(CurRow() As Byte, PrevRow() As Byte, Interval As Long)
Dim PrevOff As Long, PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevOff = n - Interval
If PrevOff >= 0 Then PrevVal = CurRow(PrevOff)
x = CurRow(n) + (CInt(PrevRow(n)) + CInt(PrevVal)) \ 2
CopyMemory CurRow(n), x, 1
Next n
End Sub
 
Private Sub ReversePaeth(CurRow() As Byte, PrevRow() As Byte, Interval As Long)
Dim BPRow As Long, n As Long, x As Integer
Dim LeftPixOff As Long, LeftPix As Byte
Dim UpperLeftPix As Byte
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
LeftPixOff = n - Interval
If LeftPixOff >= 0 Then
LeftPix = CurRow(LeftPixOff)
UpperLeftPix = PrevRow(LeftPixOff)
End If
x = CInt(CurRow(n)) + CInt(PaethPredictor(LeftPix, PrevRow(n), UpperLeftPix))
CopyMemory CurRow(n), x, 1
Next n
End Sub
 
Private Sub ReverseUp(CurRow() As Byte, PrevRow() As Byte)
Dim PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevVal = PrevRow(n)
x = CInt(CurRow(n)) + CInt(PrevVal)
CopyMemory CurRow(n), x, 1
Next n
End Sub
 
Private Sub ReverseSub(CurRow() As Byte, Interval As Long)
Dim PrevOff As Long, PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevOff = n - Interval
If PrevOff >= 0 Then PrevVal = CurRow(PrevOff)
x = CInt(CurRow(n)) + CInt(PrevVal)
CopyMemory CurRow(n), x, 1
Next n
End Sub
 
Private Function PaethPredictor(Left As Byte, Above As Byte, UpperLeft As Byte) As Byte
Dim pA As Integer, pB As Integer, pC As Integer, p As Integer
p = CInt(Left) + CInt(Above) - CInt(UpperLeft)
pA = Abs(p - Left)
pB = Abs(p - Above)
pC = Abs(p - UpperLeft)
If (pA <= pB) And (pA <= pC) Then PaethPredictor = Left ElseIf pB <= pC Then PaethPredictor = Above Else PaethPredictor = UpperLeft End If End Function Private Sub ReverseRGB(Dat() As Byte) Dim n As Long, Tmp As Byte On Error Resume Next For n = 0 To UBound(Dat) Step 3 Tmp = Dat(n) Dat(n) = Dat(n + 2) Dat(n + 2) = Tmp Next n End Sub Private Sub Conv16To8(Dat() As Byte) '处理16位颜色深度 Dim n As Long, DestDat() As Byte, DestOff As Long ReDim DestDat((UBound(Dat) + 1) \ 2 - 1) For n = 0 To UBound(Dat) Step 2 DestDat(DestOff) = Dat(n) DestOff = DestOff + 1 Next n Dat = DestDat End Sub Private Sub Align32(BitCount As Integer, Dat() As Byte) Dim RowBytes As Long, SrcRowBytes As Long Dim y As Long, Dest() As Byte Dim SrcOff As Long, DestOff As Long If BitCount = 32 Then Exit Sub RowBytes = LineBytes(BitCount) SrcRowBytes = DataPerRow() - 1 If m_colortype = 4 Then SrcRowBytes = SrcRowBytes / 2 If RowBytes = SrcRowBytes Then Exit Sub Else ReDim Dest(RowBytes * m_height - 1) For y = 0 To m_height - 1 SrcOff = y * SrcRowBytes DestOff = y * RowBytes CopyMemory Dest(DestOff), Dat(SrcOff), SrcRowBytes Next y Dat = Dest End If End Sub Private Function LineBytes(BitCount As Integer) As Long '计算扫描线字节数 LineBytes = ((m_width * BitCount + 31) \ 32) * 4 End Function Private Sub ReverseRGBA(Dat() As Byte) Dim n As Long, Tmp As Byte For n = 0 To UBound(Dat) Step 4 Tmp = Dat(n) If n + 2 > UBound(Dat) Then Exit For
Dat(n) = Dat(n + 2)
Dat(n + 2) = Tmp
Next n
End Sub
 
Private Sub Pal2To8(Dat() As Byte, RowBytes As Long)
Dim DestDat() As Byte, DestRowBytes As Long, n As Long
Dim Px As Byte, DestOff As Long, x As Long, y As Long
DestRowBytes = LineBytes(8)
ReDim DestDat(DestRowBytes * m_height - 1)
For y = 0 To m_height - 1
DestOff = y * DestRowBytes
For x = 0 To m_width - 1
n = y * (RowBytes - 1) + x \ 4
Px = IIf((x Mod 4) <> 3, Dat(n) \ 4 ^ (3 - (x Mod 4)), Dat(n)) And 3
DestDat(DestOff) = Px
DestOff = DestOff + 1
Next x
Next y
Dat = DestDat
End Sub
 
Private Sub GrayAToRGBA(Dat() As Byte)
Dim n As Long, DestDat() As Byte, DestOff As Long
ReDim DestDat((UBound(Dat) + 1) * 2 - 1)
For n = 0 To UBound(Dat) Step 2
DestDat(DestOff) = Dat(n)
DestDat(DestOff + 1) = Dat(n)
DestDat(DestOff + 2) = Dat(n)
DestDat(DestOff + 3) = Dat(n + 1)
DestOff = DestOff + 4
Next n
Dat = DestDat
End Sub
 
Private Function BerechneZeilenltge(x As Long, Bpp As Long, Stand As String) As Long
Dim Hilfslong As Long
Dim Ltgenrest As Long
Dim Ltge8 As Long
Dim Testlong As Long
Dim Anzahl8 As Long
Dim AnzahlBits As Long
Dim Bytesrest As Long
Dim NBytes As Long
Dim AnzRB As Long
Dim Rest As Long
Dim MengeBits As Long
Dim i As Long
Dim BiggerAs As Long
Dim Menge As Long
MengeBits = Len(Stand)
Ltgenrest = x Mod 8
BiggerAs = 0
Menge = 0
For i = 1 To MengeBits
If CLng(Mid(Stand, i, 1)) <= Ltgenrest Then Menge = Menge + 1 Else Exit For End If Next i If Bpp < 8 Then If Ltgenrest > 0 Then
Rest = Bpp * Menge
Else
Rest = 0
End If
Else
Rest = Menge * (Bpp / 8)
End If
Anzahl8 = (x - Ltgenrest) / 8
AnzahlBits = Anzahl8 * Bpp * MengeBits
Bytesrest = AnzahlBits Mod 8
NBytes = (AnzahlBits - Bytesrest) / 8
Select Case Bpp
Case Is < 8 Rest = Rest + Bytesrest Testlong = Rest Mod 8 AnzRB = (Rest - Testlong) / 8 If Testlong <> 0 Then AnzRB = AnzRB + 1
BerechneZeilenltge = NBytes + AnzRB
Case Else
BerechneZeilenltge = NBytes + Rest
End Select
End Function
 
'处理带α通道数据的图像
Private Sub MakeAlpha(Buffer() As Byte)
Dim Myx As Long, Myy As Long, DatOff As Long, R As Long, G As Long, b As Long, a As Long
Dim sR As Long, sG As Long, sB As Long, dR As Long, dG As Long, dB As Long
Dim DestData() As Byte, SrcData() As Byte, hdc As Long, bytesperrow As Long
Dim DestOff As Long, DestHdr As BITMAPINFOHEADER
Dim MemDC As Long, hBmp2 As Long, hOldBmp As Long
On Error Resume Next
If Err.Number = 91 Then
ReDim SrcData(UBound(Buffer))
bytesperrow = LineBytes(24)
FillColorArray SrcData, 0, bytesperrow
ReDim DestData(bytesperrow * m_height - 1)
Err.Clear
Else
hdc = m_PicBox.hdc
bytesperrow = LineBytes(24)
ReDim DestData(bytesperrow * m_height - 1), SrcData(UBound(Buffer))
DestHdr.BitCount = 24
DestHdr.Height = m_height
DestHdr.Width = m_width
DestHdr.Planes = 1
DestHdr.Size = 40
MemDC = CreateCompatibleDC(hdc)
hBmp2 = CreateCompatibleBitmap(hdc, m_width, m_height)
hOldBmp = SelectObject(MemDC, hBmp2)
BitBlt MemDC, 0, 0, m_width, m_height, hdc, m_Bgx, m_Bgy, vbSrcCopy
GetDIBits MemDC, hBmp2, 0, m_height, SrcData(0), DestHdr, 0
SelectObject hOldBmp, MemDC
DeleteObject hBmp2
DeleteDC MemDC
End If

For Myy = 0 To m_height - 1
For Myx = 0 To m_width - 1
DestOff = Myy * bytesperrow + Myx * 3
sR = SrcData(DestOff + 2)
sG = SrcData(DestOff + 1)
sB = SrcData(DestOff)
b = Buffer(DatOff)
G = Buffer(DatOff + 1)
R = Buffer(DatOff + 2)
a = Buffer(DatOff + 3)
If a = 255 Then
DestData(DestOff + 2) = R
DestData(DestOff + 1) = G
DestData(DestOff) = b
ElseIf a = 0 Then
DestData(DestOff + 2) = sR
DestData(DestOff + 1) = sG
DestData(DestOff) = sB
Else
dR = R * a + (255 - a) * sR + 255
dG = G * a + (255 - a) * sG + 255
dB = b * a + (255 - a) * sB + 255
CopyMemory DestData(DestOff + 2), ByVal VarPtr(dR) + 1, 1
CopyMemory DestData(DestOff + 1), ByVal VarPtr(dG) + 1, 1
CopyMemory DestData(DestOff), ByVal VarPtr(dB) + 1, 1
End If
DatOff = DatOff + 4
Next Myx
Next Myy
Buffer = DestData
End Sub
 
Private Sub MirrorData(Dat() As Byte, RowBytes As Long)
Dim NewDat() As Byte, y As Long, Height As Long
Dim StartLine As Long, DestLine As Long
ReDim NewDat(UBound(Dat))
Height = (UBound(Dat) + 1) \ RowBytes
For y = 0 To Height - 1
StartLine = y * RowBytes
DestLine = (Height - y - 1) * RowBytes
CopyMemory NewDat(DestLine), Dat(StartLine), RowBytes
Next y
Dat = NewDat
End Sub
 
Private Sub FillColorArray(FArray() As Byte, Color As Long, bytesperrow As Long)
Dim DA(3) As Byte, i As Long, u As Byte, Ztler As Long
CopyMemory DA(0), ByVal VarPtr(Color), 3
If DA(3) = 0 Then
u = DA(0)
DA(0) = DA(2)
DA(2) = u
u = DA(1)
If DA(0) = DA(1) And DA(1) = DA(2) Then
FillMemory FArray(0), UBound(FArray) + 1, DA(0)
Else
Ztler = 1
For i = 0 To UBound(FArray) - 2 Step 3
CopyMemory FArray(i), DA(0), 3
If i = ((Ztler * bytesperrow) - 1) Or i = ((Ztler * bytesperrow) - 2) Then
i = Ztler * bytesperrow
i = bytesperrow * Ztler
Ztler = Ztler + 1
End If
Next i
End If
End If
End Sub
 
Private Function Interval() As Long '间隔
Interval = BitsPerPixel() \ 8
If Interval = 0 Then Interval = 1
End Function
 
Public Property Get Text() As String '返回文本信息
Text = m_text
End Property
 
Public Property Get Width() As Long '返回图像宽
Width = m_width
End Property
 
Public Property Get Height() As Long '返回图像高
Height = m_height
End Property
 
Public Property Get Bitdepht() As Long '返回颜色深度
Bitdepht = m_bitdepht
End Property
 
Public Property Get ColorType() As Long '返回颜色类型
ColorType = m_colortype
End Property
 
Private Sub InitColorTable_1(Optional Sorting As Integer = 1)
Dim Fb1 As Byte, Fb2 As Byte
Select Case Sorting
Case 0: Fb1 = 255: Fb2 = 0
Case 1: Fb1 = 0: Fb2 = 255
End Select
bm1.bmiColors(0).rgbRed = Fb1
bm1.bmiColors(0).rgbGreen = Fb1
bm1.bmiColors(0).rgbBlue = Fb1
bm1.bmiColors(0).rgbReserved = 0
bm1.bmiColors(1).rgbRed = Fb2
bm1.bmiColors(1).rgbGreen = Fb2
bm1.bmiColors(1).rgbBlue = Fb2
bm1.bmiColors(1).rgbReserved = 0
End Sub
 
Private Sub InitColorTable_1Palette(Palettenbyte() As Byte)
If UBound(Palettenbyte) = 5 Then
bm1.bmiColors(0).rgbRed = Palettenbyte(0)
bm1.bmiColors(0).rgbGreen = Palettenbyte(1)
bm1.bmiColors(0).rgbBlue = Palettenbyte(2)
bm1.bmiColors(0).rgbReserved = 0
bm1.bmiColors(1).rgbRed = Palettenbyte(3)
bm1.bmiColors(1).rgbGreen = Palettenbyte(4)
bm1.bmiColors(1).rgbBlue = Palettenbyte(5)
bm1.bmiColors(1).rgbReserved = 0
Else
InitColorTable_1
End If
End Sub
 
Private Sub InitColorTable_8(ByteArray() As Byte)
Dim Palette8() As RGBTriple, i As Integer
ReDim Palette8(255)
CopyMemory Palette8(0), ByteArray(0), UBound(ByteArray) + 1
On Error Resume Next
For i = 0 To 255 '256色位图调色板
bm8.bmiColors(i).rgbBlue = Palette8(i).Blue
bm8.bmiColors(i).rgbGreen = Palette8(i).Green
bm8.bmiColors(i).rgbRed = Palette8(i).Red
bm8.bmiColors(i).rgbReserved = 0
Next i
End Sub
 
Private Sub InitColorTable_4(ByteArray() As Byte)
Dim Palette4() As RGBTriple, i As Integer
ReDim Palette4(15)
CopyMemory Palette4(0), ByteArray(0), UBound(ByteArray) + 1
For i = 0 To 15 '16色位图调色板
bm4.bmiColors(i).rgbRed = Palette4(i).Red
bm4.bmiColors(i).rgbGreen = Palette4(i).Green
bm4.bmiColors(i).rgbBlue = Palette4(i).Blue
bm4.bmiColors(i).rgbReserved = 0
Next i
End Sub
 
Private Sub CreateBitmap_1(ByteArray() As Byte, Orientation As Integer, Optional Colorused As Long = 0)
Dim hdc As Long
With bm1.bmiHeader
.Size = Len(bm1.bmiHeader)
.Width = m_width
.Height = IIf(Orientation = 0, m_height, -m_height)
.Planes = 1
.BitCount = 1
.Compression = 0&
.SizeImage = 0
.XPelsPerMeter = 0
.YPelsPerMeter = 0
.ClrUsed = Colorused
.ClrImportant = 0
End With
hdc = GetDC(0)
hBmp = CreateDIBitmap_1(hdc, bm1.bmiHeader, &H4, ByteArray(0), bm1, 0)
End Sub
 
Private Sub CreateBitmap_4(ByteArray() As Byte, Orientation As Integer, Optional Colorused As Long = 0)
Dim hdc As Long
With bm4.bmiHeader
.Size = Len(bm1.bmiHeader)
.Width = m_width
.Height = IIf(Orientation = 0, m_height, -m_height)
.Planes = 1
.BitCount = 4
.Compression = 0&
.SizeImage = 0
.XPelsPerMeter = 0
.YPelsPerMeter = 0
.ClrUsed = Colorused
.ClrImportant = 0
End With
hdc = GetDC(0)
hBmp = CreateDIBitmap_4(hdc, bm4.bmiHeader, &H4, ByteArray(0), bm4, 0)
End Sub
 
Private Sub CreateBitmap_8(BitmapArray() As Byte, Orientation As Integer, Optional Colorused As Long = 0)
Dim hdc As Long
With bm8.bmiHeader
.Size = Len(bm8.bmiHeader)
.Width = m_width
.Height = IIf(Orientation = 0, m_height, -m_height)
.Planes = 1
.BitCount = 8
.Compression = 0&
.SizeImage = 0
.XPelsPerMeter = 0
.YPelsPerMeter = 0
.ClrUsed = Colorused
.ClrImportant = 0
End With
hdc = GetDC(0)
hBmp = CreateDIBitmap_8(hdc, bm8.bmiHeader, &H4, BitmapArray(0), bm8, 0)
End Sub
 
Private Sub DrawBitmap() '绘制位图
Dim cDC As Long
If hBmp Then
cDC = CreateCompatibleDC(m_PicBox.hdc)
SelectObject cDC, hBmp
Call StretchBlt(m_PicBox.hdc, m_Bgx, m_Bgy, m_width * m_multiple, m_height * m_multiple, cDC, 0, 0, m_width, m_height, vbSrcCopy)
DeleteDC cDC
DeleteObject hBmp
hBmp = 0
End If
m_PicBox.Picture = m_PicBox.Image
End Sub
 
'根据BitmapArray()创建一个与设备无关位图
Private Sub CreateBitmap_24(ByteArray() As Byte, Orientation As Integer, Optional ThreeToOrToFour As Integer = 0)
Dim hdc As Long
Dim Bits() As RGBQUAD
Dim BitsA() As RGBTriple
Select Case ThreeToOrToFour
Case 0
ReDim Bits((UBound(ByteArray) / 4) - 1)
CopyMemory Bits(0), ByteArray(0), UBound(ByteArray)
With bm24.bmiHeader
.Size = Len(bm24.bmiHeader)
.Width = m_width '位图宽
.Height = IIf(Orientation = 0, m_height, -m_height) '位图高
.BitCount = 32 '32位色深
.Planes = 1 '位面板
.Compression = 0& '不压缩
.SizeImage = 0
.XPelsPerMeter = 0
.YPelsPerMeter = 0
.ClrUsed = 0
.ClrImportant = 0
End With
Case 1
ReDim BitsA((UBound(ByteArray) / 3) - 1)
CopyMemory BitsA(0), ByteArray(0), UBound(ByteArray)
With bm24a.bmiHeader
.Size = Len(bm24.bmiHeader)
.Width = m_width
.Height = IIf(Orientation = 0, m_height, -m_height)
.BitCount = 24
.Planes = 1
.Compression = 0&
.SizeImage = 0
.XPelsPerMeter = 0
.YPelsPerMeter = 0
.ClrUsed = 0
.ClrImportant = 0
End With
End Select
hdc = GetDC(0)
Select Case ThreeToOrToFour
Case 0: hBmp = CreateDIBitmap_24(hdc, bm24.bmiHeader, &H4, Bits(0), bm24, 0)
Case 1: hBmp = CreateDIBitmap_24a(hdc, bm24a.bmiHeader, &H4, BitsA(0), bm24a, 0)
End Select
End Sub
 
Private Function InitColorTable_Grey(BitDepth As Long, Optional To8Bit As Boolean = False) As Byte()
Dim CurLevel As Integer, Tergabe() As Byte, n As Long, LevelDiff As Byte
Dim Tbl() As RGBQUAD, Table3() As RGBTriple
Erase bm8.bmiColors
If BitDepth <> 16 Then
ReDim Tbl(2 ^ BitDepth - 1), Table3(2 ^ BitDepth - 1)
Else
ReDim Tbl(255), Table3(255)
End If
LevelDiff = 255 / UBound(Tbl)
For n = 0 To UBound(Tbl)
With Tbl(n)
.rgbRed = CurLevel
.rgbGreen = CurLevel
.rgbBlue = CurLevel
End With
With Table3(n)
.Red = CurLevel
.Green = CurLevel
.Blue = CurLevel
End With
CurLevel = CurLevel + LevelDiff
Next n
Select Case BitDepth
Case 1
If To8Bit = True Then
CopyMemory ByVal VarPtr(bm8.bmiColors(0).rgbBlue), ByVal VarPtr(Tbl(0).rgbBlue), 8
End If
Case 2
CopyMemory ByVal VarPtr(bm8.bmiColors(0).rgbBlue), ByVal VarPtr(Tbl(0).rgbBlue), 16
Case 4
If To8Bit = True Then
CopyMemory ByVal VarPtr(bm8.bmiColors(0).rgbBlue), ByVal VarPtr(Tbl(0).rgbBlue), 64
Else
CopyMemory ByVal VarPtr(bm4.bmiColors(0).rgbBlue), ByVal VarPtr(Tbl(0).rgbBlue), 64
End If
Case 8
CopyMemory ByVal VarPtr(bm8.bmiColors(0).rgbBlue), ByVal VarPtr(Tbl(0).rgbBlue), 1024
End Select
ReDim Tergabe(((UBound(Table3) + 1) * 3) - 1)
CopyMemory Tergabe(0), ByVal VarPtr(Table3(0).Red), ((UBound(Table3) + 1) * 3)
InitColorTable_Grey = Tergabe
End Function