mdlstorage.bas

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

Attribute VB_Name = "mdlStorage"
'*********************************************************************************************
'
' DocumentProperties/Storage
'
' Support functions and declarations module
'
'*********************************************************************************************
'
' Author: Eduardo Morcillo
' E-Mail: [e-mail]
' Web Page: http://www.domaildlx.com/e_morcillo
'
' Created: 07/31/1999
' Updates:
'           08/12/1999. The comments were revised and enhaced.
'           08/02/1999. IsValidVariant was removed.
'           12/13/1999. Added 1 parameter to CreateFileStorage
'*********************************************************************************************

Option Explicit

Public FMTID_SummaryInformation As IID
Public FMTID_DocSummaryInformation As IID
Public FMTID_UserProperties As IID

Public FMTID_Init As Boolean

Public Declare Function lstrcpyA Lib "kernel32" (ByVal Dest As Any, Src As Any) As Long

Public Const CLSCTX_INPROC_SERVER = 1

Declare Function CoCreateInstance Lib "ole32" (rclsid As IID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As IID, ppv As Object) As Long

Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpPathName As String, ByVal lpPrefixString As String, ByVal uUnique As Long, ByVal lpTempFileName As String) As Long
Declare Function OleLoadPictureFile Lib "oleaut32" (ByVal varFileName As Variant, lplpdispPicture As Object) As Long

'*********************************************************************************************
'
' Creates the standar property sets in the given storage
'
' Parameters:
'
' Stg: source storage where the property set will be created.
' ANSI: indicates if properties are written in ANSI or Unicode. Default is ANSI.
'
' Returns: True if there's no error.
'
'*********************************************************************************************
Public Function CreatePropertySets(ByVal Stg As Storage, Optional ByVal ANSI As Boolean = True) As Boolean
Dim IPSS As IPropertySetStorage, FMTID As IID, Clsid As IID
Dim Flgs As Long

    On Error Resume Next
    
    ' Get IPropertySetStorage
    Set IPSS = Stg.Storage
    
    ' Set flags
    If ANSI Then
        Flgs = PROPSETFLAG_ANSI
    Else
        Flgs = PROPSETFLAG_DEFAULT
    End If
    
    ' Create SummaryInformation and
    ' DocumentSummaryInformation property
    ' storages
    IIDFromString FMTID_SummaryInformationStr, FMTID
    IPSS.create FMTID, Clsid, Flgs, STGM_CREATE Or STGM_READWRITE Or STGM_SHARE_EXCLUSIVE
    
    IIDFromString FMTID_DocSummaryInformationStr, FMTID
    IPSS.create FMTID, Clsid, Flgs, STGM_CREATE Or STGM_READWRITE Or STGM_SHARE_EXCLUSIVE
    
    IIDFromString FMTID_UserPropertiesStr, FMTID
    IPSS.create FMTID, Clsid, Flgs, STGM_CREATE Or STGM_READWRITE Or STGM_SHARE_EXCLUSIVE

    CreatePropertySets = Err.Number = 0
    
End Function

'*********************************************************************************************
'
' Opens an storage file
'
' Parameters:
'
' Filename: full path & name of the file
'
'*********************************************************************************************
Function OpenFileStorage(ByVal FileName As String) As Storage

    Set OpenFileStorage = New Storage
    
    Set OpenFileStorage.Storage = StgOpenStorage(FileName, , STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
    
End Function

'*********************************************************************************************
'
' Creates a new structured storage file
'
' Parameters:
'
' FileName: full path and name of the file
' CreatePropSets: automatically creates the standard property sets
' KillPrevious: deletes the any previous file with the same name
'
'*********************************************************************************************
Function CreateFileStorage(ByVal FileName As String, Optional CreatePropSets As Boolean = True, Optional ByVal ANSI As Boolean = True, Optional KillPrevious As Boolean = False) As Storage

    On Error Resume Next
    
    ' Create a new Storage object
    Set CreateFileStorage = New Storage
        
    ' Create storage file
    Set CreateFileStorage.Storage = StgCreateDocfile(FileName, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE Or (-STGM_CREATE * KillPrevious))
    
    ' The storage file already
    ' exists
    If Err.Number = 58 Then
            
        ' Open the file
        Set CreateFileStorage.Storage = StgOpenStorage(FileName, , STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
        
        CreatePropSets = False
        
    End If
    
    If CreatePropSets Then CreatePropertySets CreateFileStorage, ANSI
    
End Function

'*********************************************************************************************
'
' Initializes FMTIDs from the FMTID strings
'
'*********************************************************************************************
Public Sub InitFMTIDs()

    FMTID_Init = True
    
    IIDFromString FMTID_SummaryInformationStr, FMTID_SummaryInformation
    IIDFromString FMTID_DocSummaryInformationStr, FMTID_DocSummaryInformation
    IIDFromString FMTID_UserPropertiesStr, FMTID_UserProperties

End Sub

'*********************************************************************************************
'
' Returns a String from a LPxSTR pointer
'
' Parameters:
'
' Ptr: pointer to the string
' FreeSource: If True the source string pointer if freed.
' Unicode: Indicates if the source string is Unicode or ANSI. Default is ANSI.
'
'*********************************************************************************************
Public Function Ptr2Str(Ptr As Long, Optional FreeSource As Boolean, Optional ByVal Unicode As Boolean) As String

    If Unicode Then
        
        ' The string is Unicode
        
        ' Get string length to initialize
        ' the string.
        Ptr2Str = String$(lstrlenW(Ptr), 0)
        
        ' Copy the string
        MoveMemory ByVal StrPtr(Ptr2Str), ByVal Ptr, Len(Ptr2Str) * 2
    
    Else
        
        ' Get string length to initialize
        ' the string.
        Ptr2Str = String$(lstrlenA(Ptr), 0)
        
        ' Copy the string
        lstrcpyA Ptr2Str, ByVal Ptr
        
    End If

    If FreeSource Then CoTaskMemFree Ptr: Ptr = 0
    
End Function

'*********************************************************************************************
'
' Converts a LPSTR or LPWSTR variant to String.
'
' Parameters:
'
' Var: source variant
'
'*********************************************************************************************
Public Function ToBSTR(Var As Variant) As String
Dim VType As Integer, Ptr As Long

    ' Get variant type
    VType = VarType(Var)
            
    If VType = VT_LPSTR Then
    
        ' ANSI String
        
        ' Get string pointer
        MoveMemory Ptr, ByVal VarPtr(Var) + 8, 4
    
        ' Copy string from pointer
        ToBSTR = Ptr2Str(Ptr, , False)
        
    ElseIf VType = VT_LPWSTR Then
        
        ' Unicode String
           
        ToBSTR = Ptr2Str(Ptr, , True)
        
    End If
    
    ' Clear the variant
    PropVariantClear Var
    
End Function

'*********************************************************************************************
'
' Converts a FILETIME variant to Date
'
' Parameters:
'
' Var: source variant
'
'*********************************************************************************************
Public Function ToDate(Var As Variant) As Date
Dim FT As Currency, ST As SYSTEMTIME, LocalFT As Currency
Dim Serial As Double

    ' Get FILETIME from variant
    MoveMemory FT, ByVal VarPtr(Var) + 8, Len(FT)
    
    ' Date properties are in UTC. Convert to
    ' Local time.
    FileTimeToLocalFileTime FT, LocalFT
    
    ' Convert FILETIME to SYSTEMTIME
    FileTimeToSystemTime LocalFT, ST
    
    ' Convert SYSTEMTIME to Date
    SystemTimeToVariantTime ST, Serial
    
    ' Set the return value
    ToDate = Serial
    
    ' Clear source variant
    PropVariantClear Var
    
End Function

'*********************************************************************************************
'
' Converts a Date to FILETIME variant
'
' Parameters:
'
' Value: source date
' Var: destination variant
'
'*********************************************************************************************
Public Sub ToFILETIME(ByVal Value As Date, Var As Variant)
Dim ST As SYSTEMTIME, FT As Currency

    ' Convert Date to SYSTEMTIME
    VariantTimeToSystemTime Value, ST
    
    ' Convert SYSTEMTIME to FILETIME
    SystemTimeToFileTime ST, FT
    
    ' Convert Local FILETIME to UTC FILETIME.
    ' Date properties must be saved in UTC.
    LocalFileTimeToFileTime FT, FT

    ' Clear any previous content
    PropVariantClear Var
    
    ' Set the variant type
    MoveMemory ByVal VarPtr(Var), VT_FILETIME, 2
    
    ' Copy the FILETIME to the variant
    MoveMemory ByVal VarPtr(Var) + 8, FT, Len(FT)
    
End Sub

'*********************************************************************************************
'
' Creates a LPSTR or LPWSTR variant from VB string
'
' Parameters:
'
' BSTR: Source string
' Var: destination variant
' Unicode: indicates if the result string must be ANSI or Unicode. Default is ANSI.
'
'*********************************************************************************************
Public Sub ToLPSTR(ByVal BSTR As String, Var As Variant, Optional ByVal Unicode As Boolean)
Dim VarType As Integer, Ptr As Long

    ' Set the string type
    If Unicode Then
        VarType = VT_LPWSTR ' Unicode
    Else
        VarType = VT_LPSTR  ' ANSI
    End If
    
    ' Add null char at the end of the
    ' string.
    BSTR = BSTR & vbNullChar
    
    If Unicode Then
        
        ' Allocate memory for the new string
        Ptr = CoTaskMemAlloc(Len(BSTR) * 2)
        
        ' Copy string from BSTR to the
        ' allocated memory
        MoveMemory ByVal Ptr, ByVal BSTR, Len(BSTR) * 2
    
    Else
    
        ' Allocate memory for the new string
        Ptr = CoTaskMemAlloc(Len(BSTR))
        
        ' Copy string from BSTR to the
        ' allocated memory
        lstrcpyA Ptr, ByVal BSTR
    
    End If
    
    ' Clear any previuos content from
    ' the variant
    PropVariantClear Var
    
    ' Write variant type
    MoveMemory Var, VarType, 2
 
    ' Write pointer
    MoveMemory ByVal VarPtr(Var) + 8, Ptr, 4

End Sub

'*********************************************************************************************
'
' Creates a array of strings from a variant containing a counted array of LPWSTR or LPSTR
'
' Parameters:
'
' Var: source variant
' Unicode: indicates if the source is ANSI or Unicode. Default is ANSI.
'
'*********************************************************************************************
Public Function ToBSTRArray(Var As Variant, Optional ByVal Unicode As Boolean) As Variant
Dim A() As String, Cnt As Long, PtrElem As Long
Dim PtrStr As Long

    ' Get element count from variant
    MoveMemory Cnt, ByVal VarPtr(Var) + 8, 4
    
    ' Get pointer to first element
    MoveMemory PtrElem, ByVal VarPtr(Var) + 12, 4

    ' Reallocate the VB array
    ReDim A(0 To Cnt - 1)
    
    For Cnt = 0 To Cnt - 1
        
        ' Get pointer to the string
        MoveMemory PtrStr, ByVal PtrElem, 4
        
        ' Copy the string from the pointer
        If Unicode Then
        
            A(Cnt) = Space$(lstrlenW(PtrStr))
            MoveMemory ByVal StrPtr(A(Cnt)), ByVal PtrStr, Len(A(Cnt)) * 2
            
        Else
        
            A(Cnt) = Space$(lstrlenA(PtrStr))
            lstrcpyA A(Cnt), ByVal PtrStr
            
        End If
        
        ' Move to next element
        PtrElem = PtrElem + 4
        
    Next
    
    ' Clear the source variant
    PropVariantClear Var
        
    ' Return the VB array
    ToBSTRArray = A
    
End Function

'*********************************************************************************************
'
' Creates a counted array of LPSTR from a VB array of strings
'
' Parameters:
'
' Value: source array
' Var: destination variant
'
'*********************************************************************************************
Public Sub ToLPSTRArray(Value As Variant, Var As Variant)
Dim ArrPtr As Long, ElemPtr As Long, PtrStr As Long
Dim Cnt As Long, I As Long, TmpStr As String

    ' Get element count
    Cnt = UBound(Value) - LBound(Value) + 1

    ' Alloc memory for the array. We
    ' must save each string pointer
    ' in the array. Each pointer have
    ' 4 bytes.
    ArrPtr = CoTaskMemAlloc(Cnt * 4)
    
    ' Set pointer to first element
    ElemPtr = ArrPtr
        
    For I = LBound(Value) To UBound(Value)
    
        ' Alloc memory for the string
        PtrStr = CoTaskMemAlloc(Len(Value(I)) + 1)
        
        ' Copy string pointer to array element
        MoveMemory ByVal ElemPtr, PtrStr, 4
        
        ' Copy string to string pointer
        TmpStr = Value(I) & vbNullChar
        lstrcpyA PtrStr, ByVal TmpStr
                
        ' Move element pointer to next element
        ElemPtr = ElemPtr + 4
        
    Next
    
    ' Set variant type
    MoveMemory ByVal VarPtr(Var), VT_VECTOR Or VT_LPSTR, 2
    
    ' Set variant element count
    MoveMemory ByVal VarPtr(Var) + 8, Cnt, 4
    
    ' Set Array pointer
    MoveMemory ByVal VarPtr(Var) + 12, ArrPtr, 4
    
End Sub