Converting 32x32 StdPicture icons to PNG

Question

I am trying to convert an StdPicture into a PNG before encoding it to Base64 to be sent over XML. I've gotten the Base64 encoding portion down (see near end of function EncodeImageToBase64()) however I am having trouble converting the StdPicture object into a PNG byte array.

Here's my function:

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

The problem is that the people who wrote CreatePngByteArray only intended the function to convert PNG's of 16x16. Thus my 32x32 icons fail the assertion that's in the function:

'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

I've looked over this code relentlessly but I have not done very much low-level programming (dealing with bytes and whatnot) and have come up far short.

Is there any way to repurpose this, or any other way to be able to convert PNG images of any size into byte arrays? If I'm going to be using libraries /.dlls I prefer they be standard Microsoft ones.

Thanks!

Answer 1

You can use a property bag like this

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