将 32x32 StdPicture 图标转换为 PNG

Question

我正在尝试将 StdPicture 转换为 PNG，然后再将其编码为 Base64 以通过 XML 发送。我已经获取了 Base64 编码部分（请参阅函数的近端 EncodeImageToBase64()）但是我无法将 StdPicture 对象转换为 PNG 字节数组。

这是我的函数：

Private Function EncodeImageToBase64(ByRef Image As StdPicture) As String
  Dim xmlDoc As DOMDocument60
  Dim xmlNode As MSXML2.IXMLDOMElement
  Dim bColor() As Byte
  Dim bMask() As Byte
  Dim bImage() As Byte
  Dim lCrcTable() As Long
  Dim lWidth As Long
  Dim lHeight As Long
  EncodeImageToBase64 = vbNullString

  If Image Is Nothing Then
    Exit Function
  End If

  Call MakeCRC32Table(lCrcTable)
  Call IconPicToArrays(Image, bColor, bMask, lWidth, lHeight)
  If Not CreatePngByteArray(bImage, lWidth, lHeight, bColor, bMask, lCrcTable) Then
    Debug.Assert False
    Exit Function
  End If
  'Call GetPictureBits(bImage, Image)

  Set xmlDoc = New DOMDocument60
  Set xmlNode = xmlDoc.createElement("b64")
  xmlNode.DataType = "bin.base64"
  xmlNode.nodeTypedValue = bImage
  EncodeImageToBase64 = xmlNode.Text

  Set xmlNode = Nothing
  Set xmlDoc = Nothing
End Function

问题是写 CreatePngByteArray 的人只打算用这个函数来转换 PNG 的 16x16。因此，我的 32x32 图标无法通过函数中的断言：

'Create PNG (RFC-2083) image based on a 16x16 icon's color and mask bitmaps
Public Function CreatePngByteArray(ByRef bTarget() As Byte, ByVal Width As Long, ByVal _
      Height As Long, bColor() As Byte, bMask() As Byte, lCrcTable() As Long) As Boolean
  Dim bIndex() As Byte
  Dim bPalette() As Byte
  Dim lPos As Long
  Dim lCRC As Long
  Dim X As Long
  Dim Y As Long
  Dim z As Long
  Dim lPalSize As Long

  If Width > 16 Or Height > 16 Then Exit Function

  lPalSize = RGBtoPalette(bColor, bMask, bIndex, bPalette, Width, Height)

  ReDim bTarget(0 To 364 + lPalSize) As Byte '8+25+(12+lPalSize)+13+295+12-1

  'PNG signature 'long val = -1991225785  'hex value = 89504E47
  bTarget(0) = 137
  bTarget(1) = 80
  bTarget(2) = 78
  bTarget(3) = 71
  bTarget(4) = 13
  bTarget(5) = 10
  bTarget(6) = 26
  bTarget(7) = 10
  lPos = 8

  'IHDR
  Call FlipLongToArray(13, bTarget(), lPos)
  Call FlipLongToArray(pctIHDR, bTarget(), lPos + 4) 'add chunk flag
  Call FlipLongToArray(Width, bTarget(), lPos + 8)
  Call FlipLongToArray(Height, bTarget(), lPos + 12)
  bTarget(lPos + 16) = 8  'bit depth
  bTarget(lPos + 17) = 3  'color type
  bTarget(lPos + 18) = 0  'compression - none
  bTarget(lPos + 19) = 0  'filter
  bTarget(lPos + 20) = 0  'interlace
  lCRC = CRC32(bTarget(), lPos + 4, lPos + 20, lCrcTable())
  Call FlipLongToArray(lCRC, bTarget(), lPos + 21)
  lPos = lPos + 25

  'PLTE
  Call FlipLongToArray(lPalSize, bTarget(), lPos)
  Call FlipLongToArray(pctPLTE, bTarget(), lPos + 4)   'add chunk flag
  Call CopyMemory(bTarget(lPos + 8), bPalette(0), lPalSize)
  lCRC = CRC32(bTarget(), lPos + 4, lPos + lPalSize + 7, lCrcTable())
  Call FlipLongToArray(lCRC, bTarget(), lPos + lPalSize + 8)
  lPos = lPos + lPalSize + 12

  'tRNS
  Call FlipLongToArray(1, bTarget(), lPos)
  Call FlipLongToArray(pcttRNS, bTarget(), lPos + 4)  'add chunk flag
  bTarget(lPos + 8) = 0 'alpha
  lCRC = CRC32(bTarget(), lPos + 4, lPos + 8, lCrcTable())
  Call FlipLongToArray(lCRC, bTarget(), lPos + 9)
  lPos = lPos + 13

  'IDAT
  Call FlipLongToArray(283, bTarget(), lPos)
  Call FlipLongToArray(pctIDAT, bTarget(), lPos + 4)  'add chunk flag
  bTarget(lPos + 8) = 24 '8=deflate + 16=512b LZ77 window (RFC-1950)
  bTarget(lPos + 9) = 25 'so that (CompMethod*256 + AddlFlags) Mod 31=0 (RFC-1950)
  bTarget(lPos + 10) = 1 '(RFC-1951)
  bTarget(lPos + 11) = 16 '272: LEN 0 (RFC-1951)
  bTarget(lPos + 12) = 1 '272: LEN 1
  bTarget(lPos + 13) = &HEF '~272: NLEN 0 (RFC-1951)
  bTarget(lPos + 14) = &HFE '~272: NLEN 1
  For X = 0 To 15
    bTarget(lPos + 15 + z) = 0
    Call CopyMemory(bTarget(lPos + 16 + z), bIndex(Y), 16)
    Y = Y + 16
    z = z + 17
  Next X
  lCRC = Adler32(bTarget(), lPos + 15, lPos + 286)
  Call FlipLongToArray(lCRC, bTarget(), lPos + 287) 'Adler32 is supposed to be safe to leave empty, but isn't
  lCRC = CRC32(bTarget(), lPos + 4, lPos + 290, lCrcTable())
  Call FlipLongToArray(lCRC, bTarget(), lPos + 291)
  lPos = lPos + 295

  'IEND
  Call FlipLongToArray(0, bTarget(), lPos)
  Call FlipLongToArray(pctIEND, bTarget(), lPos + 4)   'add chunk flag
  lCRC = CRC32(bTarget(), lPos + 4, lPos + 7, lCrcTable())
  Call FlipLongToArray(lCRC, bTarget(), lPos + 8)

  CreatePngByteArray = True
End Function

我不厌其烦地查看了这段代码，但我并没有做太多的低级编程（处理字节和诸如此类的东西），而且还差得很远。

有没有什么方法可以改变它的用途，或者有什么其他方法可以将任何大小的 PNG 图像转换为字节数组？如果我要使用库 /.dll，我更喜欢它们是标准的 Microsoft 库。

谢谢！

Answer 1

你可以像这样使用属性包

Option Explicit

Private Sub Form_Load()
    Dim encoded     As String

    encoded = EncodeImageToBase64(LoadPicture("d:\temp\aaa.gif"))
    Caption = "Encoded Size: " & Len(encoded)
    Set Picture = DecodeImageFromBase64(encoded)
End Sub

Private Function EncodeImageToBase64(ByRef Image As StdPicture) As String
    Dim oBag        As PropertyBag

    Set oBag = New PropertyBag
    oBag.WriteProperty "i", Image, Nothing
    With VBA.CreateObject("MSXML2.DOMDocument").createElement("dummy")
        .DataType = "bin.base64"
        .NodeTypedValue = oBag.Contents
        EncodeImageToBase64 = .Text
    End With
End Function

Private Function DecodeImageFromBase64(ByRef Base64 As String) As StdPicture
    Dim oBag        As PropertyBag
    Dim QH          As Long

    On Error GoTo QH
    Set oBag = New PropertyBag
    With VBA.CreateObject("MSXML2.DOMDocument").createElement("dummy")
        .DataType = "bin.base64"
        .Text = Base64
        oBag.Contents = .NodeTypedValue
    End With
    Set DecodeImageFromBase64 = oBag.ReadProperty("i", Nothing)
QH:
End Function

将 32x32 StdPicture 图标转换为 PNG

Converting 32x32 StdPicture icons to PNG

arrays

vb6

png