[VB6] Convert a picture to PNG byte-array in memory

[wqweto]

This WIA sample converts an StdPicture to a PNG byte-array without using any temporary disk storage.

Shows how to use IPicture.SaveAsFile method with plain ADODB.Stream (no CreateStreamOnHGlobal API used).

Option Explicit

Private Sub Form_Load()
    Debug.Print UBound(SaveAsPng(picTab1.Picture))
End Sub

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream     As Object ' ADODB.Stream
    Dim oImageFile  As Object ' WIA.ImageFile
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        Call pPic.SaveAsFile(ByVal ObjPtr(oStream) + 68, True, 0) '--- magic
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

JFYI, the magic offset 68 is the difference between ObjPtr of IUnknown and IStream casts of an ADODB.Stream instance.

Using Picture property on WIA.Vector converts all StdPicture subtypes (like Enhanced Metafiles or Icons) to vbPicTypeBitmap because WIA's Convert filter fails on anything but a serialized vbPicTypeBitmap 32bbp image it seems.

cheers,
</wqw>

[xxdoc123]

Good knowledge
.but

 Call pPic.SaveAsFile(ByVal ObjPtr(oStream) + 68, True, 0) '--- magic

in my system win7 32.china. program crashed .

[xxdoc123]

This WIA sample converts an StdPicture to a PNG byte-array without using any temporary disk storage.

Shows how to use IPicture.SaveAsFile method with plain ADODB.Stream (no CreateStreamOnHGlobal API used).

Option Explicit

Private Sub Form_Load()
    Debug.Print UBound(SaveAsPng(picTab1.Picture))
End Sub

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream     As Object ' ADODB.Stream
    Dim oImageFile  As Object ' WIA.ImageFile
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        Call pPic.SaveAsFile(ByVal ObjPtr(oStream) + 68, True, 0) '--- magic
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

JFYI, the magic offset 68 is the difference between ObjPtr of IUnknown and IStream casts of an ADODB.Stream instance.

Using Picture property on WIA.Vector converts all StdPicture subtypes (like Enhanced Metafiles or Icons) to vbPicTypeBitmap because WIA's Convert filter fails on anything but a serialized vbPicTypeBitmap 32bbp image it seems.

cheers,
</wqw>

can fixed?

[xxdoc123]

Good knowledge
.but

 Call pPic.SaveAsFile(ByVal ObjPtr(oStream) + 68, True, 0) '--- magic

in my system win7 32.china. program crashed .

win10 work fine

[wqweto]

For Win7 the magic offset seems to be 76 which is unfortunate.

If you need this for serious work just add reference to Microsoft InkEdit Control 1.0 in Components (not References, this is an OCX) and call SaveAsFile method like this instead

        Dim pStream As IStream
        Set pStream = oStream
        Call pPic.SaveAsFile(ByVal ObjPtr(pStream), True, 0)

. . . without any magic offsets.

These offsets depend on ADO version and probably the compiler version and options used to build the ADO and OS so clearly playing with fire here.

Another option would be to use DispCallFunc API function to call IUnknown::QueryInterface on oStream for IID_IStream which would save the InkEdit reference but needs an API declare.

cheers,
</wqw>

[The trick]

Another option would be to use DispCallFunc API function to call IUnknown::QueryInterface on oStream for IID_IStream which would save the InkEdit reference but needs an API declare.

You could use __vbaCastObj function as well:

Option Explicit

Private Declare Function vbaCastObj Lib "msvbvm60" _
                         Alias "__vbaCastObj" ( _
                         ByRef cObj As Any, _
                         ByRef pIID As Any) As Long
Private Declare Function PutMem4 Lib "msvbvm60" ( _
                         ByRef pDst As Any, _
                         ByVal NewValue As Long) As Long

Private Sub Form_Load()
    Debug.Print UBound(SaveAsPng(Me.Picture))
End Sub

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream     As Object ' ADODB.Stream
    Dim oImageFile  As Object ' WIA.ImageFile
    Dim cIStream    As IUnknown
    Dim bIID_IStream(3)    As Long
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        
        bIID_IStream(0) = &HC
        bIID_IStream(2) = &HC0
        bIID_IStream(3) = &H46000000
        
        CastObj ObjPtr(oStream), VarPtr(bIID_IStream(0)), VarPtr(cIStream)
        
        Call pPic.SaveAsFile(ByVal ObjPtr(cIStream), True, 0)   '--- NO magic
        
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

Private Function CastObj( _
                 ByVal pObj As Long, _
                 ByVal pIID As Long, _
                 ByVal ppObj As Long) As Long
    Dim pCast   As Long
    
    On Error GoTo error_handler
    
    pCast = vbaCastObj(ByVal pObj, ByVal pIID)
    PutMem4 ByVal ppObj, pCast
    
    Exit Function
    
error_handler:
                     
    CastObj = Err.Number
                     
End Function

[wqweto]

Here is the DispCallFunc based fix

Option Explicit

Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long

Private Sub Form_Load()
    Debug.Print UBound(SaveAsPng(Me.Picture))
End Sub

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary  As Long = 1
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Const CC_STDCALL    As Long = 4
    Dim oStream         As Object ' ADODB.Stream
    Dim oImageFile      As Object ' WIA.ImageFile
    Dim IID_IStream(3)  As Long
    Dim pStream         As IUnknown
    Dim vParams(0 To 1) As Variant
    Dim vType(0 To 1)   As Integer
    Dim vPtr(0 To 1)    As Long
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        '--- call IUnknown::QI on oStream for IStream interface and store in pStream
        IID_IStream(0) = &HC
        IID_IStream(2) = &HC0
        IID_IStream(3) = &H46000000
        vParams(0) = VarPtr(IID_IStream(0))
        vParams(1) = VarPtr(pStream)
        vType(0) = VarType(vParams(0))
        vType(1) = VarType(vParams(1))
        vPtr(0) = VarPtr(vParams(0))
        vPtr(1) = VarPtr(vParams(1))
        Call DispCallFunc(ObjPtr(oStream), 0, CC_STDCALL, vbLong, UBound(vParams) + 1, vType(0), vPtr(0), Empty)
        '--- NO magic anymore, only business as usual
        pPic.SaveAsFile ByVal ObjPtr(pStream), True, 0
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

cheers,
</wqw>

[dilettante]

You can also use DexterLib.IStream defined in Dexter 1.0 Type Library, qedit.dll, part of DirectShow. This should be a stable typelib shipping in Windows going back a long way to at least Windows 2000.

I've used it for an IStream definition for other operations but I haven't tried it with this.

[Schmidt]

And (FWIW), a VB.PropertyBag based variation:

Public Function SaveAsPng(Pic As StdPicture) As Byte()
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim PB As PropertyBag, oImageFile As Object 'WIA.ImageFile
 
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
       Set PB = New PropertyBag
           PB.WriteProperty "Pic", Pic
       With CreateObject("WIA.Vector")
         .BinaryData = MidB(PB.Contents, 51) '<- "magic" ;-)
         If Pic.Type <> vbPicTypeBitmap Then
           Set Pic = .Picture 'convert Pic to vbPicTypeBitmap
         Else
           Set oImageFile = .ImageFile
         End If
       End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
End Function

Olaf

[Elroy]

Maybe this is a bit different, but I just use GdipSaveImageToFile in the GDI+ to get this done.

Private Declare Function GdipSaveImageToFile Lib "GdiPlus" (ByVal image As Long, ByVal pFilename As Long, ClsidEncoder As ClassIdType, ByVal pEncoderParams As Any) As Long

I use GdipLoadImageFromFile to open them. I'd have to dig it out, but I've used a combination of the GDI and GDI+ to move this stuff between byte arrays, StdPicture, and GDI+ picture. IDK, I guess there are multiple ways to skin this cat.

------

The Targa (TGA) format is another tricky one. I've never found any native Windows support for that one. I've used a combination of Tanner Helland's and LaVolpe's work to get that done.

------

Typically, the only reason I'm messing with either of these is because I'd like to manipulate an image with an alpha channel in it. (Also, many web uploads seem to prefer PNG.) GIFs are fine for alpha masking, but PNG and TGA seem to be best if you want a fully "blendable" alpha channel.

[xiaoyao]

how to show Png from byte array?

this code only support jpg,bmp

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As stdole.IUnknown) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (ByVal pStream As Long, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As stdole.IUnknown) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpwsz As Long, pclsid As Any) As Long
Private Const ERROR_SUCCESS = 0&

'https://blog.csdn.net/miaozk2006/article/details/82417098

Function ShowPictureFromStream(ByRef bPic() As Byte) As StdPicture
    Dim IID_IPicture As GUID
    Dim IStm As stdole.IUnknown, IPic As IPicture
    Dim PicW As Long, PicH As Long
   
    If CreateStreamOnHGlobal(VarPtr(bPic(0)), 1, IStm) = ERROR_SUCCESS Then
        If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture) = ERROR_SUCCESS Then
            If OleLoadPicture(ByVal ObjPtr(IStm), UBound(bPic) + 1, 0, IID_IPicture, IPic) = ERROR_SUCCESS Then
                PicW = Form1.ScaleX(IPic.Width, vbHimetric, vbPixels)
                PicH = Form1.ScaleY(IPic.Height, vbHimetric, vbPixels)
                Set ShowPictureFromStream = IPic
            End If
        End If
        Set IStm = Nothing
    End If
    Erase bPic
End Function

Sub Test9()
    Dim b() As Byte
   
    Open App.Path & "\001.png" For Binary As #1
    b = InputB(LOF(1), 1)
    Close #1
   
    Set Form1.Picture = ShowPictureFromStream(b)
    Erase b
End Sub

[wqweto]

Try this

Function ShowPictureFromStream(ByRef bPic() As Byte) As StdPicture
    With CreateObject("WIA.Vector")
        .BinaryData = bPic
        Set ShowPictureFromStream = .Picture
    End With
End Function

This understands PNG an TIFF file formats besides standard BMP, GIF, and JPEG.

cheers,
</wqw>

[dilettante]

WIA 2.0's interfaces have maintained binary compatibility from the beginning. There really isn't any need to rely on late binding and hand-rolled constants like this.

[anycoder]

There's a discrete SHWeakQueryInterface that's easier to work with than DispCallFunc and can help you reach the interface you need.

Private Declare Function SHInterlockedCompareExchange Lib "shlwapi" Alias "#342" (ByVal Target As Long, ByVal Exchange As Long, ByVal Comparand As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByVal pGuid As Long) As Long
Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
 

Public Function WeakQueryInterface(ByVal aObj As Object, AOut As Object, ByVal aIID As String) As Boolean
    Dim IID(0 To 3) As Long
    Dim pUnknown  As IUnknown, Dummy As IUnknown
    CLSIDFromString StrPtr(aIID), VarPtr(IID(0))
    Set Dummy = aObj 'pre add ref
    If SHWeakQueryInterface(ObjPtr(aObj), ObjPtr(aObj), VarPtr(IID(0)), VarPtr(pUnknown)) = 0 Then
       Set AOut = pUnknown
       SHInterlockedCompareExchange VarPtr(Dummy), 0, ObjPtr(Dummy)
       WeakQueryInterface = True
    End If
End Function
Private Sub Command1_Click()
   Const IStreamGUID = "{0000000C-0000-0000-C000-000000000046}"
   Dim Stream As Object
   Dim ob As Object
   Set Stream = CreateObject("ADODB.Stream")
   If WeakQueryInterface(Stream, ob, IStreamGUID) Then
      MsgBox "ok"
   End If
End Sub

[HackerVlad]

There's a discrete SHWeakQueryInterface that's easier to work with than DispCallFunc and can help you reach the interface you need.

Private Declare Function SHInterlockedCompareExchange Lib "shlwapi" Alias "#342" (ByVal Target As Long, ByVal Exchange As Long, ByVal Comparand As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByVal pGuid As Long) As Long
Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
 

Public Function WeakQueryInterface(ByVal aObj As Object, AOut As Object, ByVal aIID As String) As Boolean
    Dim IID(0 To 3) As Long
    Dim pUnknown  As IUnknown, Dummy As IUnknown
    CLSIDFromString StrPtr(aIID), VarPtr(IID(0))
    Set Dummy = aObj 'pre add ref
    If SHWeakQueryInterface(ObjPtr(aObj), ObjPtr(aObj), VarPtr(IID(0)), VarPtr(pUnknown)) = 0 Then
       Set AOut = pUnknown
       SHInterlockedCompareExchange VarPtr(Dummy), 0, ObjPtr(Dummy)
       WeakQueryInterface = True
    End If
End Function
Private Sub Command1_Click()
   Const IStreamGUID = "{0000000C-0000-0000-C000-000000000046}"
   Dim Stream As Object
   Dim ob As Object
   Set Stream = CreateObject("ADODB.Stream")
   If WeakQueryInterface(Stream, ob, IStreamGUID) Then
      MsgBox "ok"
   End If
End Sub

Can I use SHWeakQueryInterface to implement all the basic functions for working with IStream streams?
I am interested in the possibility of implementing reading and writing to IStream, for example, without DispCallFunc. Do you have such a code?

[HackerVlad]

It looks like SHWeakQueryInterface is an undocumented feature. I couldn't find a description of this feature anywhere in the Microsoft documentation.

SHInterlockedCompareExchange doesn't seem to be documented anywhere either, but there is only one mention of this function here on the Microsoft website in the documentation: https://learn.microsoft.com/en-us/wi...lwapi-wrappers

It is referred to as a redirect to the InterlockedCompareExchangePointer function.

I would like to know more about these undocumented functions and their real-world examples.

[DrBobby]

Geoff Chappell has documented quite a lot of the undocumented stuff. The page for SHWeakQueryInterface seems pretty complete to me.

SHWeakQueryInterface:
https://www.geoffchappell.com/studie...yinterface.htm

[xiaoyao]

hwo to Public Function SaveAsjpg/bmp(Pic As StdPicture) As Byte()

Some methods have very short code, but they run slower.

Some methods may use a lot of APIs, but it runs fast.

[VanGoghGaming]

I'd say the PropertyBag solution offered by Olaf above is among the most elegant. Also I don't see the point of this clunky "SHWeakQueryInterface" function especially when VB6 already offers this functionality with the "vbaCastObj" function as pointed out by TheTrick above.

[HackerVlad]

I'd say the PropertyBag solution offered by Olaf above is among the most elegant. Also I don't see the point of this clunky "SHWeakQueryInterface" function especially when VB6 already offers this functionality with the "vbaCastObj" function as pointed out by TheTrick above.

I noticed that in this most elegant solution proposed by Olaf, the size of the output data for the saved PNG differs from other methods. Most likely, the PNG data is different for some reason. It's weird, isn't it?

I also noticed that the code suggested by The Trick does not work in Twin Basic. The vbaCastObj function is crashed by the Twin Basic IDE.
Therefore, it is better to use Olaf's function, most likely - it works in Twin Basic, I checked.

That's why I want to contradict you. The "SHWeakQueryInterface" function may be better if it works in Twin Basic, and it's also worth noting that not everyone may have a library on their computer. msvbvm60.dll to perform the "vbaCastObj" function. But the most important thing is that vbaCastObj does not work in Twin Basic.

[VanGoghGaming]

Aside from the fact that "msvbvm60.dll" is already present by default on all versions of Windows since XP, you do not need to use it in tB since most of its exported functions have been rewritten internally so if vbaCastObj is not working then you should raise an issue with Wayne to fix it.

As a side note you could also perform QueryInterface by using "DispCallFunc" or the preferred way by using an appropriate TypeLib that exposes the correct interfaces and then you could just use the "Set" keyword.

[HackerVlad]

By the way "msvbvm60.dll" it has been shipped since Windows Millennium Edition, but I have a feeling that in Windows 12 they will stop shipping this library...
Should vbaCastObj be an internal function in Twin Basic? Are you serious?

[HackerVlad]

But I still don't understand how to explain that Olaf's function outputs a PNG file that for some reason is slightly different in content and size! It outputs a PNG file that takes up a whole kilobyte more space!

[wqweto]

Btw, in TB one can declare IStream interface with proper IID directly in code so all of the above shenanigans become moot and replaced by a simple Set statement w/o external TLB being referenced. Modern times are coming to VB-land soon. . .

[HackerVlad]

Btw, in TB one can declare IStream interface with proper IID directly in code so all of the above shenanigans become moot and replaced by a simple Set statement w/o external TLB being referenced. Modern times are coming to VB-land soon. . .

Thank you for telling me about this. However, we now need to write code that is compatible with both VB6 and Twin Basic. And the code with the vbaCastObj function is not suitable for us due to the fact that it does not work in Twin Basic. Therefore, we can only rely on DispCallFunc or SHWeakQueryInterface. But personally, I really liked the SHWeakQueryInterface feature, I will most likely use this option. However, the anycoder user code will have to be redone due to the fact that it has flaws there.

[HackerVlad]

I had to redo anycoder's user code and fix minor bugs to make everything work in the end. Here is the code that works in both VB6 and Twin Basic:

Option Explicit
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByVal pGuid As Long) As Long
Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
Private Declare Function SHInterlockedCompareExchange Lib "shlwapi" Alias "#342" (ByVal Target As Long, ByVal Exchange As Long, ByVal Comparand As Long) As Long

Public Function WeakQueryInterface(ByVal aObj As Object, AOut As IUnknown, ByVal aIID As String) As Boolean
    Dim IID(0 To 3) As Long
    Dim pUnknown  As IUnknown, Dummy As IUnknown
    
    CLSIDFromString StrPtr(aIID), VarPtr(IID(0))
    Set Dummy = aObj ' pre add ref
    
    If SHWeakQueryInterface(ObjPtr(aObj), ObjPtr(aObj), VarPtr(IID(0)), VarPtr(pUnknown)) = 0 Then
       Set AOut = pUnknown
       SHInterlockedCompareExchange VarPtr(Dummy), 0, ObjPtr(Dummy)
       WeakQueryInterface = True
    End If
End Function

Public Function anycoderSaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Const IStreamGUID = "{0000000C-0000-0000-C000-000000000046}"
    Dim oStream     As Object ' ADODB.Stream  ' input
    Dim oImageFile  As Object ' WIA.ImageFile
    Dim cIStream    As IUnknown               ' output
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        
        If WeakQueryInterface(oStream, cIStream, IStreamGUID) = True Then
            Call pPic.SaveAsFile(ByVal ObjPtr(cIStream), True, 0)   '--- NO magic
        End If
        
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        anycoderSaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

Private Sub Command1_Click()
    Dim FileNo As Integer
    Dim bArray() As Byte
    
    bArray = anycoderSaveAsPng(Me.Picture)
    Debug.Print UBound(bArray)
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\dump.png"
    Open App.Path & "\dump.png" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub

[HackerVlad]

I wrote a new version of the same code, only now there are fewer lines of code, since I abandoned the separate WeakQueryInterface function. This is how the implementation turned out now.:

Option Explicit
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, ByVal pGuid As Long) As Long
Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
Private Declare Function SHInterlockedCompareExchange Lib "shlwapi" Alias "#342" (ByVal Target As Long, ByVal Exchange As Long, ByVal Comparand As Long) As Long

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Const IStreamGUID As String = "{0000000C-0000-0000-C000-000000000046}"
    Dim oStream     As Object ' ADODB.Stream  ' input
    Dim oImageFile  As Object ' WIA.ImageFile
    Dim cIStream    As IUnknown               ' output
    Dim Dummy As IUnknown
    Dim IID(0 To 3) As Long
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        
        Set Dummy = oStream ' pre add ref
        CLSIDFromString StrPtr(IStreamGUID), VarPtr(IID(0))
        If SHWeakQueryInterface(ObjPtr(oStream), ObjPtr(oStream), VarPtr(IID(0)), VarPtr(cIStream)) = 0 Then
            SHInterlockedCompareExchange VarPtr(Dummy), 0, ObjPtr(Dummy)
            '--- NO magic anymore, only business as usual
            Call pPic.SaveAsFile(ByVal ObjPtr(cIStream), True, 0)
        End If
        
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

Private Sub Command1_Click()
    Dim FileNo As Integer
    Dim bArray() As Byte
    
    bArray = SaveAsPng(Me.Picture)
    Debug.Print UBound(bArray)
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\dump4.png"
    Open App.Path & "\dump4.png" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub

[HackerVlad]

I came up with another version of the code, where the IStream is completely controlled via the API, without the need to create object "ADODB.Stream":

Option Explicit
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (ByVal pInit As Long, ByVal cbInit As Long) As Long
Private Declare Function IStream_Size Lib "shlwapi" Alias "#214" (ByVal ptrIStream As Long, ULARGE_INTEGER As Currency) As Long
Private Declare Function IStream_Reset Lib "shlwapi" Alias "#213" (ByVal ptrIStream As Long) As Long
Private Declare Function IStream_Read Lib "shlwapi" Alias "#184" (ByVal ptrIStream As Long, ByVal pv As Long, ByVal cb As Long) As Long
Private Declare Sub IUnknown_AtomicRelease Lib "shlwapi" Alias "#169" (ppUnk As Any)

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim newStream As Long
    Dim sizeStream As Currency
    Dim sizeByteArray As Long
    Dim oImageFile As Object ' WIA.ImageFile
    Dim bArray() As Byte
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        newStream = SHCreateMemStream(0, 0)
        Call pPic.SaveAsFile(ByVal newStream, True, 0)
        
        IStream_Size newStream, sizeStream
        If sizeStream > 0 Then sizeByteArray = sizeStream * 10000@
        
        If sizeByteArray > 0 Then
            ReDim bArray(sizeByteArray - 1)
            IStream_Reset newStream
            IStream_Read newStream, VarPtr(bArray(0)), sizeByteArray
            IUnknown_AtomicRelease newStream
        Else
            GoTo QH
        End If
        
        With CreateObject("WIA.Vector")
            .BinaryData = bArray
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

Private Sub Command1_Click()
    Dim FileNo As Integer
    Dim bArray() As Byte
    
    bArray = SaveAsPng(Me.Picture)
    Debug.Print UBound(bArray)
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\dump_new.png"
    Open App.Path & "\dump_new.png" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub

[HackerVlad]

Here is another more compact code of the same code, only with automatic memory release

Option Explicit
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (ByVal pInit As Long, ByVal cbInit As Long) As IUnknown
Private Declare Function IStream_Read Lib "shlwapi" Alias "#184" (ByVal ptrIStream As IUnknown, ByVal pv As Long, ByVal cb As Long) As Long
Private Declare Function IStream_Reset Lib "shlwapi" Alias "#213" (ByVal ptrIStream As IUnknown) As Long
Private Declare Function IStream_Size Lib "shlwapi" Alias "#214" (ByVal ptrIStream As IUnknown, ULARGE_INTEGER As Currency) As Long

Public Function SaveAsPng(pPic As IPicture) As Byte()
    Const adTypeBinary As Long = 1
    Const wiaFormatPNG As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim hStream As IUnknown
    Dim sizeStream As Currency
    Dim sizeByteArray As Long
    Dim oImageFile As Object ' WIA.ImageFile
    Dim bArray() As Byte
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set hStream = SHCreateMemStream(0, 0)
        Call pPic.SaveAsFile(ByVal ObjPtr(hStream), True, 0)
        
        IStream_Size hStream, sizeStream
        If sizeStream > 0 Then sizeByteArray = sizeStream * 10000@
        
        If sizeByteArray > 0 Then
            ReDim bArray(sizeByteArray - 1)
            IStream_Reset hStream
            IStream_Read hStream, VarPtr(bArray(0)), sizeByteArray
        Else
            GoTo QH
        End If
        
        With CreateObject("WIA.Vector")
            .BinaryData = bArray
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

[HackerVlad]

In general, I would say that all this could not have been invented and that the best code is Olaf's code, but I can't say that because Olaf's code creates an output PNG file larger than all other pPic.SaveAsFile based methods to the IStream.

[anycoder]

I wrote a new version of the same code, only now there are fewer lines of code, since I abandoned the separate WeakQueryInterface function. This is how the implementation turned out now.

The good way to release the object for local use is by calling SHWeakReleaseInterface when the interface isn't placed in an object variable, SHInterlockedCompareExchange was introduced in the original code writen in VBA to deal with LongPtr which the size varies depending on the platform.. note that InterlockedCompareExchange(kernel32) isn't available on all platforms..but for vb6 it's possible to use InterlockedExchange to clear the Dummy variable ..

Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
Private Declare Sub SHWeakReleaseInterface Lib "shlwapi" Alias "#268" (ByVal Outer As Long, ByVal Dest As Long)
 
Public Function SaveAsPng(ByVal pPic As IPicture) As Byte()
    Const adTypeBinary  As Long = 1
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream         As Object ' ADODB.Stream
    Dim oImageFile      As Object ' WIA.ImageFile
    Dim IID_IStream(3)  As Long
    Dim pStream         As Long
    Dim Dummy As IUnknown
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        '--- call IUnknown::QI on oStream for IStream interface and store in pStream
        IID_IStream(0) = &HC
        IID_IStream(2) = &HC0
        IID_IStream(3) = &H46000000
        Set Dummy = oStream
        If SHWeakQueryInterface(ObjPtr(oStream), ObjPtr(oStream), VarPtr(IID_IStream(0)), VarPtr(pStream)) = 0 Then
           pPic.SaveAsFile ByVal pStream, True, 0
           SHWeakReleaseInterface ObjPtr(oStream), VarPtr(pStream)
        End If
         
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

[anycoder]

but I can't say that because Olaf's code creates an output PNG file larger than all other pPic.SaveAsFile based methods to the IStream.

Since the image was opened and kinda edited in that PropertyBag and because the PNG is compressed image the size will depend on its contents.

Also the images are exported with different resolutions:
72 ppi for Olaf's version and 96 for the rest.
Resolution test

    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        Dim img
        Set img = .Apply(oImageFile)
        MsgBox CInt(img.VerticalResolution)
        SaveAsPngOlaf = img.FileData.BinaryData
    End With

[HackerVlad]

I also checked that the Olaf's function outputs a file where the total number of all image colors is less than the total number of PNG image colors using all other functions.
Should we conclude from this that it is better not to use Olaf's function?

[HackerVlad]

Since the image was opened and kinda edited in that PropertyBag and because the PNG is compressed image the size will depend on its contents.

Also the images are exported with different resolutions:
72 ppi for Olaf's version and 96 for the rest.
Resolution test

    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        Dim img
        Set img = .Apply(oImageFile)
        MsgBox CInt(img.VerticalResolution)
        SaveAsPngOlaf = img.FileData.BinaryData
    End With

It turns out that Olaf's function gives us a PNG file that is worse in quality?

[HackerVlad]

The good way to release the object for local use is by calling SHWeakReleaseInterface when the interface isn't placed in an object variable, SHInterlockedCompareExchange was introduced in the original code writen in VBA to deal with LongPtr which the size varies depending on the platform.. note that InterlockedCompareExchange(kernel32) isn't available on all platforms..but for vb6 it's possible to use InterlockedExchange to clear the Dummy variable ..

Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
Private Declare Sub SHWeakReleaseInterface Lib "shlwapi" Alias "#268" (ByVal Outer As Long, ByVal Dest As Long)
 
Public Function SaveAsPng(ByVal pPic As IPicture) As Byte()
    Const adTypeBinary  As Long = 1
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream         As Object ' ADODB.Stream
    Dim oImageFile      As Object ' WIA.ImageFile
    Dim IID_IStream(3)  As Long
    Dim pStream         As Long
    Dim Dummy As IUnknown
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        '--- call IUnknown::QI on oStream for IStream interface and store in pStream
        IID_IStream(0) = &HC
        IID_IStream(2) = &HC0
        IID_IStream(3) = &H46000000
        Set Dummy = oStream
        If SHWeakQueryInterface(ObjPtr(oStream), ObjPtr(oStream), VarPtr(IID_IStream(0)), VarPtr(pStream)) = 0 Then
           pPic.SaveAsFile ByVal pStream, True, 0
           SHWeakReleaseInterface ObjPtr(oStream), VarPtr(pStream)
        End If
         
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

anycoder, thank you so much for providing the new code. However, I found two lines of code that are not used in your function. Is it possible to completely throw them out?

1.

Dim Dummy As IUnknown

2.

Set Dummy = oStream

[HackerVlad]

I took the liberty and deleted these two extra lines of code. Here is my final version of this code:

Option Explicit
Private Declare Function SHWeakQueryInterface Lib "shlwapi" Alias "#267" (ByVal Outer As Long, ByVal Inner As Long, ByVal riid As Long, ByVal pOut As Long) As Long
Private Declare Sub SHWeakReleaseInterface Lib "shlwapi" Alias "#268" (ByVal Outer As Long, ByVal Dest As Long)

Public Function SaveAsPng(ByVal pPic As IPicture) As Byte()
    Const adTypeBinary  As Long = 1
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Dim oStream         As Object ' ADODB.Stream
    Dim oImageFile      As Object ' WIA.ImageFile
    Dim IID_IStream(3)  As Long
    Dim pStream         As Long
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        '--- call IUnknown::QI on oStream for IStream interface and store in pStream
        IID_IStream(0) = &HC
        IID_IStream(2) = &HC0
        IID_IStream(3) = &H46000000
        
        If SHWeakQueryInterface(ObjPtr(oStream), ObjPtr(oStream), VarPtr(IID_IStream(0)), VarPtr(pStream)) = 0 Then
           pPic.SaveAsFile ByVal pStream, True, 0
           SHWeakReleaseInterface ObjPtr(oStream), VarPtr(pStream)
        End If
        
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> vbPicTypeBitmap Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .ImageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

Private Sub Command1_Click()
    Dim FileNo As Integer
    Dim bArray() As Byte
    
    bArray = SaveAsPng(Me.Picture)
    Debug.Print UBound(bArray)
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\dump5.png"
    Open App.Path & "\dump5.png" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub

[HackerVlad]

I'd say the PropertyBag solution offered by Olaf above is among the most elegant. Also I don't see the point of this clunky "SHWeakQueryInterface" function especially when VB6 already offers this functionality with the "vbaCastObj" function as pointed out by TheTrick above.

As you can see now, this elegant code from Olaf turned out to be worse than other options, given the changed size of the output file, even the number of colors inside the file changes, and the file deteriorates and gets worse.

As for the "clunky" SHWeakQueryInterface function, as you said, I completely disagree with you. You can see for yourself that the option of the new code itself from the user anycoder is now much better and more worthy than the option via vbaCastObj.

[HackerVlad]

It turns out that Olaf's function gives us a PNG file that is worse in quality?

I checked, by the way, in my operating system, Olaf's code also gave 96 DPI. But I believe you that in your operating system, on your computer, this value is 72 DPI.

[fafalone]

Or you could, ya know, just have an oleexp.tlb reference...

   Dim Stream As Object 
   Set Stream = CreateObject("ADODB.Stream")
   Dim pis As IStream
   Set pis = Stream

Set is a wrapper for QueryInterface and the above will work without any magic offset, DispCallFunc mess, or undocumented API.

I understand the desire to not have to distribute any additional dependencies with an exe but IDE only dependencies? Don't understand why opposition to them is so widespread. tB is perfect then, because you can define it right there...

[InterfaceId("0c733a30-2a1c-11ce-ade5-00aa0044773d")]
[OleAutomation(False)]
Interface ISequentialStream Extends stdole.IUnknown
    Function Read(pv As Any, ByVal cb As Long) As Long
    Function Write(pv As Any, ByVal cb As Long) As Long
End Interface
[InterfaceId("0000000c-0000-0000-C000-000000000046")]
[OleAutomation(False)]
Interface IStream Extends ISequentialStream
    Function Seek(ByVal dlibMove As LongLong, ByVal dwOrigin As STREAM_SEEK) As LongLong
    Sub SetSize(ByVal libNewSize As LongLong)
    Sub CopyTo(ByVal pStm As IStream, ByVal cb As LongLong, pcbRead As LongLong, pcbWritten As LongLong)
    Sub Commit(ByVal grfCommitFlags As STGC)
    Sub Revert()
    Sub LockRegion(ByVal libOffset As LongLong, ByVal cb As LongLong, ByVal dwLockType As LOCKTYPE)
    Sub UnlockRegion(ByVal libOffset As LongLong, ByVal cb As LongLong, ByVal dwLockType As LOCKTYPE)
    Sub Stat(pstatstg As STATSTG, ByVal grfStatFlag As STATFLAG)
    Function Clone() As IStream
End Interface

[FormDesignerId("DC5AB447-69B4-455D-8176-63CFA5682839")]
[ClassId("F3F8ABBD-23AC-498C-BB03-7903E1DBEBF1")]
[InterfaceId("CB3F5BF1-F472-461F-A573-C78C5D39889D")]
[EventInterfaceId("2A8C3A91-4F1C-41B8-9D97-D629476C061D")]
Class Form1
    Option Explicit
    Private Sub Form_Load() Handles Form.Load
        Dim Stream As Object
        Dim ob As Object
        Set Stream = CreateObject("ADODB.Stream")
        Dim ps As IStream
        Set ps = Stream
    End Sub
End Class

I omitted the enums but I think the point was made for people who'd probably want to avoid checking the box for WinDevLib as a reference too even though it's not an external typelib like oleexp

[HackerVlad]

Yes, it's really very convenient in Twin Basic.
However, I want to explain why we rely on late binding. Because the function can easily be shared with other people by simply copying text without any additional files. It is this convenience of sharing the code with other people that makes us abandon early linking and TLB.