浏览器

开发平台：
Visual Basic

cStorage.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cStorage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'cStorage 使用"结构化存储"
'2004-9-15  正在看一本讲com的书,今天恰好看到"结构化存储"这部分,
'           发现是好东西啊,不过使用起来好像并不太方便,于是写下这个类
'8/5/2005   :strconv 增加使用了 LocaleID参数
Option Explicit
'Private mFn As Long
Private mOpened As Boolean
Private mStorage() As olelib.IStorage
Private mStgCnt As Long
Private mStream As olelib.IStream
Public Function OpenFile(nfile As String, path As String) As Boolean
'On Error Resume Next
Dim tStg As olelib.IStorage
'Dim tstm As olelib.IStream
Dim tstr() As String, tUb As Long
Dim i&
Dim rtn As Boolean
Call CloseFile
rtn = True
Set tStg = OpenRootStorage(nfile)
If Not tStg Is Nothing Then
    tstr = Split(path, "")
    tUb = UBound(tstr)
    ReDim mStorage(0 To tUb)
    mStgCnt = tUb + 1
    Set mStorage(0) = tStg
    For i = 0 To tUb
        If i < tUb Then
            Set mStorage(i + 1) = OpenStorage(mStorage(i), tstr(i))
            If mStorage(i + 1) Is Nothing Then
                rtn = False
                Exit For
            End If
        Else
            Set mStream = OpenStream(mStorage(i), tstr(i))
            If mStream Is Nothing Then
                rtn = False
                Exit For
            End If
        End If
    Next i
Else
    rtn = False
End If
If rtn Then
    mOpened = True
Else
    mStgCnt = 0
    ReDim mStorage(0 To mStgCnt)
    Set mStream = Nothing
End If
OpenFile = rtn
End Function
Private Function OpenRootStorage(nfile As String) As olelib.IStorage
On Error Resume Next
Dim tRoot As olelib.IStorage
Set tRoot = StgCreateDocfile(nfile, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
If tRoot Is Nothing Then
    Set tRoot = StgOpenStorage(nfile, Nothing, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE, vbNullString)
End If
Set OpenRootStorage = tRoot
End Function
Private Function OpenStorage(nStg As olelib.IStorage, pwcsName As String) As olelib.IStorage
On Error Resume Next
Dim tStg As olelib.IStorage
Set tStg = nStg.CreateStorage(pwcsName, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
If tStg Is Nothing Then
    Set tStg = nStg.OpenStorage(pwcsName, 0, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
End If
Set OpenStorage = tStg
End Function
Private Function OpenStream(nStg As olelib.IStorage, pwcsName As String) As olelib.IStream
On Error Resume Next
Dim tstm As olelib.IStream
Set tstm = nStg.CreateStream(pwcsName, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
If tstm Is Nothing Then
    Set tstm = nStg.OpenStream(pwcsName, 0, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
End If
Set OpenStream = tstm
End Function
Public Function CloseFile() As Boolean
mStgCnt = 0
ReDim mStorage(0 To mStgCnt)
Set mStream = Nothing
mOpened = False
End Function
Public Function GetStream() As olelib.IStream
Set GetStream = mStream
End Function
'Public Function WriteStringLng(ByVal nStr As String) As Boolean
'Dim tLen&
'If mOpened Then
'    nStr = StrConv(nStr, vbFromUnicode)
'    tLen = LenB(nStr)
'    mStream.Write ByVal VarPtr(tLen), 4
'    mStream.Write ByVal StrPtr(nStr), tLen
'End If
'End Function
'
'Public Function ReadStringLng(nStr As String) As Boolean
'Dim tLen&
'Dim tArr() As Byte
'If mOpened Then
'    mStream.Read ByVal VarPtr(tLen), 4
'    ReDim tArr(0 To tLen - 1)
'    mStream.Read ByVal VarPtr(tArr(0)), tLen
'    nStr = StrConv(tArr, vbUnicode)
'End If
'End Function
Public Function WriteString(ByVal nStr As String, Optional lenbytes As Long = 4) As Boolean
Dim tLen&
If lenbytes > 4 Or lenbytes < 0 Then lenbytes = 1
If mOpened Then
    nStr = StrConv(nStr, vbFromUnicode, LocaleID_CurUse)
    tLen = LenB(nStr)
    mStream.Write ByVal VarPtr(tLen), lenbytes
    mStream.Write ByVal StrPtr(nStr), tLen
End If
End Function
Public Function GetString(Optional lenbytes As Long = 4) As String
Dim tLen&
Dim tArr() As Byte
If lenbytes > 4 Or lenbytes < 0 Then lenbytes = 1
If mOpened Then
    mStream.Read ByVal VarPtr(tLen), lenbytes
    If tLen > 0 Then
        ReDim tArr(0 To tLen - 1)
        mStream.Read ByVal VarPtr(tArr(0)), tLen
        GetString = StrConv(tArr, vbUnicode, LocaleID_CurUse)
    End If
Else
    GetString = ""
End If
End Function
'获得整数
Public Function GetInteger(Optional lenbytes As Long = 4) As Long
Dim tVal&
If lenbytes > 4 Or lenbytes < 0 Then lenbytes = 1
If mOpened Then
    mStream.Read ByVal VarPtr(tVal), lenbytes
    GetInteger = tVal
End If
End Function
'写入整数
Public Function PutInteger(ByVal nVal&, Optional lenbytes As Long = 4) As Boolean
If lenbytes > 4 Or lenbytes < 0 Then lenbytes = 1
If mOpened Then
    mStream.Write ByVal VarPtr(nVal), lenbytes
End If
End Function
Public Function GetPos() As Long
If mOpened And Not mStream Is Nothing Then
    GetPos = mStream.Seek(0, STREAM_SEEK_CUR)
End If
End Function
Public Sub SeekTo(nMoveTo As Long)
If mOpened And Not mStream Is Nothing Then
    mStream.Seek ByVal nMoveTo, STREAM_SEEK_SET
End If
End Sub
Public Function StmRead(nPt&, nSize&) As Long
If mOpened And Not mStream Is Nothing Then
    StmRead = mStream.Read(ByVal nPt, nSize)
End If
End Function
Public Function StmWrite(nPt&, nSize&) As Long
If mOpened And Not mStream Is Nothing Then
    StmWrite = mStream.Write(ByVal nPt, nSize)
End If
End Function
Private Sub Class_Initialize()
mOpened = False
End Sub
Private Sub Class_Terminate()
Call CloseFile
End Sub

						