VB图片框显示PNG图片的代码

 

　　VB图片框不能显示PNG图片，这就需要我们想点办法才行。办法如下：
　　在工程中添加一个类模块LoadPNG，添加一个窗体，在窗体上添加一个图片框、一个按纽、一个文本框。

窗体的代码：
-----------------------------------------------------
Option Explicit

 

Dim pngClass As New LoadPNG

 

Private Sub Command1_Click()
On Error GoTo 100
Dim Filename As String, dlg As Object
Set dlg = CreateObject("MSComDlg.CommonDialog")
With dlg
  .DialogTitle = "打开"
  .Flags = &H1808
  .CancelError = True
  .Filter = "PNG 图片文件|*.png"
  .ShowOpen
  Filename = .Filename
End With
If Len(Filename) > 5 Then
  Pic.Picture = LoadPicture()
  Text1 = ""
  pngClass.OpenPNG Filename, Pic, , , 1.5  '参数：1-PNG文件名，2-显示图像的对象, 3、4-坐标，5-放大倍数
  Me.Caption = Mid(Filename, InStrRev(Filename, "\") + 1)
  If Len(pngClass.Text) Then Text1 = pngClass.Text
End If
100
End Sub

 

 

类模块的代码：
--------------------------------------------
Option Explicit

 

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 100
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)
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, , Signature
Test = IsValidSignature(Signature) '读出前8个字节
If Not Test Then                   '如果不是PNG标记退出
  Close Filenumber
  Exit Sub
End If

Do While Ende = False
  Get Filenumber, , Ltge        '读入长整形4个字节，这是数据块的数据域长度
  SwapBytesLong Ltge
  Get Filenumber, , ChunkName   '读入4个字节字符，这是数据块符号
  If Ltge > 0 Then ReDim ChunkInhalt(Ltge - 1) '如果不是结束块，定义数据域长度
  Stand = Seek(Filenumber)      '获取当前读入的字节位置
  If Stand + Ltge > LOF(Filenumber) Then Exit Sub '如果当前位置+数据域长度>文件长度，发生错误
  Get Filenumber, , ChunkInhalt '读入数据域
  Get Filenumber, , CRC32Inhalt '读入CRC校验码
  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
Close Filenumber

If IdataLen > 0 Then MakePicture '处理图形
100
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