[VB6/VBA] IStream wrapper module

mdStreamSupport.bas

'--- mdStreamSupport.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)

'=========================================================================
' API
'=========================================================================

'--- for IStream_Seek
Private Const STREAM_SEEK_SET               As Long = 0
Private Const STREAM_SEEK_CUR               As Long = 1
Private Const STREAM_SEEK_END               As Long = 2
'--- for SHCreateStreamOnFile
Private Const STGM_READ                     As Long = 0
Private Const STGM_WRITE                    As Long = 1
Private Const STGM_CREATE                   As Long = &H1000

#If HasPtrSafe Then
Private Declare PtrSafe Function SHCreateStreamOnFile Lib "shlwapi" Alias "SHCreateStreamOnFileW" (ByVal pszFile As LongPtr, ByVal grfMode As Long, ppStm As stdole.IUnknown) As Long
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
#Else
Private Enum LongPtr
    [_]
End Enum
Private Declare Function SHCreateStreamOnFile Lib "shlwapi" Alias "SHCreateStreamOnFileW" (ByVal pszFile As LongPtr, ByVal grfMode As Long, ppStm As stdole.IUnknown) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
#End If

'=========================================================================
' Functions
'=========================================================================

Public Function StreamOpenFile(sFile As String, Optional AlwaysCreate As Variant) As stdole.IUnknown
    Dim lFlags          As Long
    Dim hResult         As Long
    
    If IsMissing(AlwaysCreate) Then
        lFlags = STGM_READ
    Else
        lFlags = STGM_WRITE Or -CBool(AlwaysCreate) * STGM_CREATE
    End If
    hResult = SHCreateStreamOnFile(StrPtr(sFile), lFlags, StreamOpenFile)
    If hResult < 0 Then
        Err.Raise hResult, , "SHCreateStreamOnFile"
    End If
End Function

Public Function StreamReadBytes(ByVal pUnk As stdole.IUnknown, Optional ByVal Size As Long = -1) As Byte()
    Dim baData()        As Byte
    Dim cTotal          As Currency
    Dim lRead           As Long
    Dim hResult         As Long
    
    If Size < 0 Then
        hResult = IStream_GetSize(pUnk, cTotal)
        If hResult < 0 Then
            Err.Raise hResult, , "IStream_GetSize"
        End If
        Size = cTotal * 10000@
    End If
    If Size = 0 Then
        baData = vbNullString
    Else
        ReDim baData(0 To Size - 1) As Byte
    End If
    hResult = IStream_Read(AsIStream(pUnk), baData, lRead)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Read"
    End If
    If lRead <> UBound(baData) + 1 Then
        If lRead = 0 Then
            baData = vbNullString
        Else
            ReDim Preserve baData(0 To lRead - 1) As Byte
        End If
    End If
    StreamReadBytes = baData
End Function

Public Function StreamWriteBytes(ByVal pUnk As stdole.IUnknown, baData() As Byte) As Long
    Dim hResult         As Long
    
    hResult = IStream_Write(AsIStream(pUnk), baData, StreamWriteBytes)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Write"
    End If
End Function

Public Function StreamEOF(ByVal pUnk As stdole.IUnknown) As Boolean
    Dim cTotal          As Currency
    Dim cCurrent        As Currency
    Dim hResult         As Long
    
    Set pUnk = AsIStream(pUnk)
    hResult = IStream_GetSize(pUnk, cTotal)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_GetSize"
    End If
    hResult = IStream_Seek(pUnk, 0, STREAM_SEEK_CUR, cCurrent)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Seek"
    End If
    StreamEOF = (cCurrent >= cTotal)
End Function

Public Function StreamSeekAbsolute(ByVal pUnk As stdole.IUnknown, ByVal Position As Currency) As Currency
    Dim hResult         As Long
    
    hResult = IStream_Seek(AsIStream(pUnk), Position / 10000@, STREAM_SEEK_SET, StreamSeekAbsolute)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Seek"
    End If
    StreamSeekAbsolute = StreamSeekAbsolute * 10000@
End Function

Public Function StreamSeekEnd(ByVal pUnk As stdole.IUnknown, ByVal Position As Currency) As Currency
    Dim hResult         As Long
    
    hResult = IStream_Seek(AsIStream(pUnk), Position / 10000@, STREAM_SEEK_END, StreamSeekEnd)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Seek"
    End If
    StreamSeekEnd = StreamSeekEnd * 10000@
End Function

Public Function StreamSeekRelative(ByVal pUnk As stdole.IUnknown, ByVal Offset As Currency) As Currency
    Dim hResult         As Long
    
    hResult = IStream_Seek(AsIStream(pUnk), Offset / 10000@, STREAM_SEEK_CUR, StreamSeekRelative)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_Seek"
    End If
    StreamSeekRelative = StreamSeekRelative * 10000@
End Function

Public Function StreamGetSize(ByVal pUnk As stdole.IUnknown) As Currency
    Dim hResult         As Long
    
    hResult = IStream_GetSize(AsIStream(pUnk), StreamGetSize)
    If hResult < 0 Then
        Err.Raise hResult, , "IStream_GetSize"
    End If
    StreamGetSize = StreamGetSize * 10000@
End Function

'= private ===============================================================

Private Function AsIStream(pUnk As stdole.IUnknown) As stdole.IUnknown
    Static IID_IStream(0 To 3) As Long
    Dim hResult         As Long
    
    If IID_IStream(0) = 0 Then
        IID_IStream(0) = &HC: IID_IStream(1) = &H0
        IID_IStream(2) = &HC0: IID_IStream(3) = &H46000000
    End If
    If Not pUnk Is Nothing Then
        hResult = DispCallByVtbl(pUnk, 0, VarPtr(IID_IStream(0)), VarPtr(AsIStream))
        If hResult < 0 Then
            Err.Raise hResult, "IUnknown_QueryInterface(IID_IStream)"
        End If
    End If
End Function

Private Function IStream_Read(pUnk As stdole.IUnknown, baData() As Byte, Optional BytesRead As Long) As Long
    If Not pUnk Is Nothing And UBound(baData) >= 0 Then
        IStream_Read = DispCallByVtbl(pUnk, 3, VarPtr(baData(0)), UBound(baData) + 1, VarPtr(BytesRead))
    End If
End Function

Private Function IStream_Write(pUnk As stdole.IUnknown, baData() As Byte, Optional BytesWritten As Long) As Long
    If Not pUnk Is Nothing And UBound(baData) >= 0 Then
        IStream_Write = DispCallByVtbl(pUnk, 4, VarPtr(baData(0)), UBound(baData) + 1, VarPtr(BytesWritten))
    End If
End Function

Private Function IStream_Seek(pUnk As stdole.IUnknown, ByVal cMove As Currency, ByVal dwOrigin As Long, Optional NewPosition As Currency) As Long
    If Not pUnk Is Nothing Then
        IStream_Seek = DispCallByVtbl(pUnk, 5, cMove, dwOrigin, VarPtr(NewPosition))
    End If
End Function

Private Function IStream_GetSize(pUnk As stdole.IUnknown, TotalBytes As Currency) As Long
    Dim cInitial        As Currency
    
    If Not pUnk Is Nothing Then
        IStream_GetSize = IStream_Seek(pUnk, 0, STREAM_SEEK_CUR, cInitial)
        If IStream_GetSize >= 0 Then
            IStream_GetSize = IStream_Seek(pUnk, 0, STREAM_SEEK_END, TotalBytes)
            IStream_Seek pUnk, cInitial, STREAM_SEEK_SET
        End If
    End If
End Function

Private Function DispCallByVtbl(pUnk As stdole.IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    Const CC_STDCALL    As Long = 4
#If Win64 Then
    Const PTR_SIZE      As Long = 8
#Else
    Const PTR_SIZE      As Long = 4
#End If
    Dim lIdx            As Long
    Dim vParam()        As Variant
    Dim vType(0 To 63)  As Integer
    Dim vPtr(0 To 63)   As LongPtr
    Dim hResult         As Long
    
    vParam = A
    For lIdx = 0 To UBound(vParam)
        vType(lIdx) = VarType(vParam(lIdx))
        vPtr(lIdx) = VarPtr(vParam(lIdx))
    Next
    hResult = DispCallFunc(ObjPtr(pUnk), lIndex * PTR_SIZE, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    If hResult < 0 Then
        Err.Raise hResult, "DispCallFunc"
    End If
End Function