vbstorage.cls

结构化存储文件我们平时大量接触的Word,Excel文件实际上都是结构化存储文件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Storage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*********************************************************************************************
'
' Storage class
'
' IStorage wrapper class
'
'*********************************************************************************************
'
' Author: Eduardo Morcillo
' E-Mail: [e-mail]
' Web Page: http://www.domaildlx.com/e_morcillo
'
' Created: 08/03/1999
'
'*********************************************************************************************
Option Explicit

Dim m_Storage As IStorage
Dim m_Stat As VBSTATSTG

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

    m_Storage.Commit Flags
    
End Sub

'*********************************************************************************************
' CreateStorage: Creates a storage object within
'                this storage
'*********************************************************************************************
Public Function CreateStorage(ByVal Name As String, Optional ByVal Flags As STGM = STGM_READWRITE Or STGM_SHARE_EXCLUSIVE) As Storage
Dim IStg As IStorage

    On Error Resume Next
    
    ' Create the IStorage object
    Set IStg = m_Storage.CreateStorage(Name, Flags, 0)
    
    ' Check if the storage
    ' already exists
    If Err.Number = 58 Then
        
        Err.Clear
        
        ' Open the storage
        Set IStg = m_Storage.OpenStorage(Name, , Flags, 0)
        
    End If
    
    ' Raise an error if
    ' something happened
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Raise Err.Number
    End If
    
    ' Create a new m_Storage object
    Set CreateStorage = New Storage
    Set CreateStorage.Storage = IStg
    
End Function

'*********************************************************************************************
' CreateStream: Creates a new stream within this storage
'*********************************************************************************************
Public Function CreateStream(ByVal Name As String, Optional ByVal Flags As STGM = STGM_READWRITE Or STGM_SHARE_EXCLUSIVE) As Stream
Dim IStrm As IStream

    On Error Resume Next

    ' Create the IStream object
    Set IStrm = m_Storage.CreateStream(Name, Flags)
    
    ' Open the stream if it already
    ' exists
    If Err.Number = 58 Then Err.Clear: Set IStrm = m_Storage.OpenStream(Name, , Flags)
    
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Raise Err.Number
    End If
    
    Set CreateStream = New Stream
    Set CreateStream.Stream = IStrm
    
End Function

'*********************************************************************************************
' DestroyElement: Removes a stream or storage from this storage
'*********************************************************************************************
Public Sub DestroyElement(ByVal Name As String)

    m_Storage.DestroyElement Name
    
End Sub

'*********************************************************************************************
' Elements: Returns a Elements collection with all the storage elements
'*********************************************************************************************
Public Function Elements() As StorageElements
Dim SSTG As STATSTG, IEnm As IEnumSTATSTG

    ' Get the storage enumerator object
    Set IEnm = m_Storage.EnumElements(0, ByVal 0, 0)
    
    ' Create a new StorageElements Object
    Set Elements = New StorageElements
    
    ' Enumerate all elements and
    ' add them to the collection
    Do While IEnm.Next(, SSTG) <> 0
        Elements.Add SSTG
    Loop
    
    Set IEnm = Nothing
        
End Function

'*********************************************************************************************
' MoveElementTo: Moves or copies elements from this storage to another
'*********************************************************************************************
Public Sub MoveElementTo(ByVal ElemName As String, ByVal DestStrg As Storage, ByVal NewName As String, ByVal Flags As STGMOVE)

    m_Storage.MoveElementTo ElemName, DestStrg.Storage, NewName, Flags
    
End Sub

'*********************************************************************************************
' OpenStorage: Opens a storage within this storage
'*********************************************************************************************
Public Function OpenStorage(ByVal Name As String, Optional ByVal Flags As STGM = STGM_READWRITE Or STGM_SHARE_EXCLUSIVE) As Storage
Dim IStg As IStorage

    ' Open the storage
    Set IStg = m_Storage.OpenStorage(Name, , Flags)
    
    ' Create a new Storage object
    Set OpenStorage = New Storage
    Set OpenStorage.Storage = IStg
    
End Function

'*********************************************************************************************
' OpenStream: opens a stream within this storage
'*********************************************************************************************
Public Function OpenStream(ByVal Name As String, Optional ByVal Flags As STGM = STGM_READWRITE Or STGM_SHARE_EXCLUSIVE) As Stream
Dim IStrm As IStream

    ' Open the stream
    Set IStrm = m_Storage.OpenStream(Name, , Flags)
    
    ' Create a new stream object
    Set OpenStream = New Stream
    Set OpenStream.Stream = IStrm
    
End Function

'*********************************************************************************************
' RenameElement: Renames a stream or storage within this storage
'*********************************************************************************************
Public Sub RenameElement(ByVal OldName As String, NewName As String)
    
    m_Storage.RenameElement OldName, NewName
    
End Sub

'*********************************************************************************************
' Revert: Reverts all non commited changes
'*********************************************************************************************
Public Sub Revert()
    
    m_Storage.Revert
    
End Sub

'*********************************************************************************************
' Storage: Returns/sets the IStorage object
'*********************************************************************************************
Friend Property Set Storage(IStg As IStorage)
Dim SSTG As STATSTG

    Set m_Storage = IStg
    
    ' Get m_Storage info
    m_Storage.Stat SSTG
    
    ' Create new VBSTATSTG object
    Set m_Stat = New VBSTATSTG
    m_Stat.SetData SSTG

End Property

Public Property Get Storage() As IStorage

    Set Storage = m_Storage

End Property

'*********************************************************************************************
' Stat: returns a VBSTATSTG object with info about this storage
'*********************************************************************************************
Public Property Get Stat() As VBSTATSTG

    Set Stat = m_Stat
    
End Property