如果讓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