VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Stream"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*********************************************************************************************
'
' Stream class
'
' IStream wrapper class
'
'*********************************************************************************************
'
' Author: Eduardo Morcillo
' E-Mail: edanmo@geocities.com
' Web Page: http://www.domaildlx.com/e_morcillo
'
' Created: 08/03/1999
' Updates:
'          08/03/1999. * WriteData was renamed to WriteBuf.
'                      * New WriteData with Buf as Variant.
'                      * ReadData was renamed to ReadBuf
'                      * New ReadData with Buf as Variant.
'
'          12/13/1999. * Stream public variable moved to
'                        read-only property
'                      * New method WriteObject
'                      * New method ReadObject
'*********************************************************************************************
Option Explicit

Dim m_Stream As IStream
Dim m_Stat As VBSTATSTG

'*********************************************************************************************
' Clone: Duplicates this object
'*********************************************************************************************
Public Function Clone() As Stream

    Set Clone = New Stream
    Set Clone.Stream = m_Stream.Clone
    
End Function

'*********************************************************************************************
' Commit: Save all changes to disk
'*********************************************************************************************
Public Sub Commit(Optional ByVal Flags As STGC = STGC_DEFAULT)

    m_Stream.Commit Flags
    
End Sub

'*********************************************************************************************
' CopyTo: Copy BufLen bytes from this stream to another
'*********************************************************************************************
Public Function CopyTo(ByVal Strm As Stream, ByVal BufLen As Currency) As Currency
Dim Rd As Currency

    BufLen = BufLen / 10000
    m_Stream.CopyTo Strm.Stream, BufLen, Rd, CopyTo
    
    If CopyTo <> Rd Then Err.Raise vbObjectError
    
    CopyTo = CopyTo * 10000
    
End Function

'*********************************************************************************************
' Revert: reverts all non commited changes
'*********************************************************************************************
Public Sub Revert()
    
    m_Stream.Revert
    
End Sub

'*********************************************************************************************
' SetSize: Sets the stream size
'*********************************************************************************************
Public Sub SetSize(ByVal NewSize As Currency)
    
    m_Stream.SetSize NewSize / 10000

End Sub

'*********************************************************************************************
' ReadBuf: reads BufLen bytes from the stream and stores
'          them in the Buf array.
'*********************************************************************************************
Public Function ReadBuf(Buf() As Byte, ByVal BufLen As Long) As Long

    ReDim Buf(0 To BufLen - 1)
    ReadBuf = m_Stream.Read(Buf(0), BufLen)
    
End Function

'*********************************************************************************************
' ReadObject: Reads and creates an object previously saved with WriteObject
'*********************************************************************************************
Public Function ReadObject() As Object
Dim IPS As IPersistStream, IPSI As IPersistStreamInit
Dim IPS_IID As IID, Clsid As IID, UseIPS As Boolean
Dim hResult As Long

    ' Get the CLSID from the stream
    m_Stream.Read Clsid, LenB(Clsid)
    
    ' Check if the CLSID is empty
    If Clsid.Data1 = 0 And Clsid.Data2 = 0 And Clsid.Data3 = 0 And _
        Clsid.Data4(0) = 0 And Clsid.Data4(1) = 0 And Clsid.Data4(2) = 0 And Clsid.Data4(3) = 0 And Clsid.Data4(4) = 0 And _
        Clsid.Data4(5) = 0 And Clsid.Data4(6) = 0 And Clsid.Data4(7) = 0 Then
    
        Set ReadObject = Nothing
        
    Else
        
        ' Get the UseIPS flag
        m_Stream.Read UseIPS, LenB(UseIPS)
        
        If UseIPS Then
            ' We've used IPersistStream to
            ' save the object data
        
            ' Fill IPS_IID with IPersistStream
            ' interface ID:
            ' {00000109-0000-0000-C000-000000000046}
            IPS_IID.Data1 = &H109
            IPS_IID.Data4(0) = &HC0
            IPS_IID.Data4(7) = &H46
            
            ' Create a instance of the object
            hResult = CoCreateInstance(Clsid, 0&, CLSCTX_INPROC_SERVER, IPS_IID, IPS)
            
            If hResult = 0 Then
            
                ' Make the object load its data
                IPS.Load m_Stream
                
                ' Return the object
                Set ReadObject = IPS
            
            Else
                Err.Raise hResult
            End If
            
        Else
            ' We've used IPersistStreamInit
            ' to save the object data
        
            ' Fill IPS_IID with IPersistStreamInit
            ' interface ID:
            ' {7FD52380-4E07-101B-AE2D-08002B2EC713}
            IPS_IID.Data1 = &H7FD52380
            IPS_IID.Data2 = &H4E07
            IPS_IID.Data3 = &H101B
            IPS_IID.Data4(0) = &HAE
            IPS_IID.Data4(1) = &H2D
            IPS_IID.Data4(2) = &H8
            IPS_IID.Data4(3) = &H0
            IPS_IID.Data4(4) = &H2B
            IPS_IID.Data4(5) = &H2E
            IPS_IID.Data4(6) = &HC7
            IPS_IID.Data4(7) = &H13
            
            hResult = CoCreateInstance(Clsid, 0&, CLSCTX_INPROC_SERVER, IPS_IID, IPSI)
            
            If hResult = 0 Then
                
                ' Make the object load its data
                IPSI.Load m_Stream
                
                ' Return the object
                Set ReadObject = IPSI
            
            Else
                Err.Raise hResult
            End If
        
        End If
        
    End If
    
End Function

'*********************************************************************************************
' ReadData: Reads data in the VType format and returns
'           it as a Variant
'*********************************************************************************************
Public Function ReadData(ByVal VType As VbVarType) As Variant
Dim Ln As Long, B() As Byte, I As Integer
Dim D As Double, C As Currency, S As Single

    Select Case VType
        Case vbString
            
            ' Read the string length
            m_Stream.Read Ln, 4
            
            ' Skip null strings
            If Ln > 0 Then
            
            
                ' Multiply the len by 2
                ' because the string is
                ' saved as wide-char string
                Ln = Ln * 2
                ReDim B(0 To Ln - 1)
            
                ' Read the data
                ReadData = m_Stream.Read(B(0), Ln)
                
            End If
            
            ' Return the data as a string
            ReadData = CStr(B)
            
        Case vbLong
            
            m_Stream.Read Ln, 4
            ReadData = Ln
        
        Case vbInteger
        
            m_Stream.Read I, 2
            ReadData = I
        
        Case vbBoolean
            
            m_Stream.Read I, 2
            ReadData = CBool(I)
        
        Case vbSingle
        
            m_Stream.Read S, 4
            ReadData = S
        
        Case vbDouble
            
            m_Stream.Read D, 8
            ReadData = D
        
        Case vbCurrency
        
            m_Stream.Read C, 8
            ReadData = C

        Case vbDate
        
            m_Stream.Read D, 8
            ReadData = CDate(D)
        
    End Select
    
End Function

'*********************************************************************************************
' SSeek: Moves the current stream position to a new one
' (this method is called SSeek because Seek is a reserved word)
'*********************************************************************************************
Public Function SSeek(ByVal NewPos As Currency) As Currency

    NewPos = NewPos / 10000
    
    SSeek = m_Stream.Seek(NewPos, 0) * 10000
    
End Function

'*********************************************************************************************
' Stat: Returns a VBSTATSTG with stream info
'*********************************************************************************************
Public Function Stat() As VBSTATSTG
    
    Set Stat = m_Stat
    
End Function

'*********************************************************************************************
' Stream: Returns/Sets(within the same project) the IStream interface
'*********************************************************************************************
Public Property Get Stream() As IStream
    
    Set Stream = m_Stream
    
End Property

Friend Property Set Stream(ByVal NewStrm As IStream)
Dim SSTG As STATSTG
    
    Set m_Stream = NewStrm
    
    m_Stream.Stat SSTG
    
    Set m_Stat = New VBSTATSTG
    m_Stat.SetData SSTG
    
End Property

'*********************************************************************************************
' WriteBuff: Writes an array in the stream
'*********************************************************************************************
Public Function WriteBuf(Buf() As Byte) As Long

    On Error Resume Next
    
    WriteBuf = m_Stream.Write(Buf(LBound(Buf)), UBound(Buf) - LBound(Buf) + 1)
    
End Function

'*********************************************************************************************
' WriteData: Writes the data stored in a Variant. Use this method to save
'            directly from variables.
'*********************************************************************************************
Public Function WriteData(Buf As Variant) As Long

    On Error Resume Next
    
    Select Case VarType(Buf)
        Case vbString
        
            ' Write the string length
            m_Stream.Write CLng(Len(Buf)), 4
            
            ' Write the string in Unicode
            ' format
            WriteData = m_Stream.Write(ByVal StrPtr(Buf), Len(Buf) * 2)
        
        Case vbLong
            WriteData = m_Stream.Write(CLng(Buf), 4)
            
        Case vbBoolean
            WriteData = m_Stream.Write(CBool(Buf), 2)
        
        Case vbInteger
            WriteData = m_Stream.Write(CInt(Buf), 2)
            
        Case vbByte
            WriteData = m_Stream.Write(CByte(Buf), 1)
            
        Case vbCurrency
            WriteData = m_Stream.Write(CCur(Buf), 8)
            
        Case vbDate
            WriteData = m_Stream.Write(CDate(Buf), 8)
            
        Case vbDouble
            WriteData = m_Stream.Write(CDbl(Buf), 8)
        
        Case vbSingle
            WriteData = m_Stream.Write(CSng(Buf), 4)
    
        Case vbObject
            WriteObject Buf
            
    End Select
    
End Function

'*********************************************************************************************
' WriteObject: Writes an object to the stream. Use this method to save pictures,
'              fonts and any object that implements IPersistStream interface.
'*********************************************************************************************
Public Sub WriteObject(ByVal Obj As Object)
Dim Clsid As IID, UseIPS As Boolean
Dim IPS As IPersistStream, IPSI As IPersistStreamInit
        
    ' Check is the object is nothing
    If Obj Is Nothing Then
    
        ' If the object is nothing save
        ' an empty CLSID to the stream
        m_Stream.Write Clsid, LenB(Clsid)
    
    Else
        
        On Error Resume Next
        
        ' Get the IPersistStream interface
        Set IPS = Obj
        
        ' If IPS is nothing the
        ' object doesn't implement
        ' IPersistm_Stream.
        
        If IPS Is Nothing Then
            
            ' Try Now
            ' with IPersistStreamInit
            Set IPSI = Obj
            
            If IPSI Is Nothing Then
                ' None of the interfaces
                ' are implemented.
                ' Raise an error (&H80004002 = E_NOINTERFACE)
                Err.Raise &H80004002, , "The object must implement IPersistStream or IPersistStreamInit"
            Else
                
                ' Get the object class ID
                IPSI.GetClassID Clsid

                ' Save the class ID to the stream
                m_Stream.Write Clsid, LenB(Clsid)
                
                ' Save which interface was used
                UseIPS = True
                m_Stream.Write UseIPS, Len(UseIPS)
                
                ' Call Save to allow the object
                ' save its data
                IPSI.Save m_Stream, False
                
            End If
            
        Else
            
            ' Get the object class ID
            IPS.GetClassID Clsid

            ' Save the class ID to the stream
            m_Stream.Write Clsid, LenB(Clsid)
            
            ' Save which interface was used
            UseIPS = True
            m_Stream.Write UseIPS, Len(UseIPS)
            
            IPS.Save m_Stream, False
        
        End If
        
    End If
    
End Sub