vbAccelerator - Contents of code file: XMLPropertyBag.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "XMLPropertyBag"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'
 -------------------------------------------------------------------------------
-
' XMLPropertyBag.
' vbAccelerator version -
'
' Based on the original code:
'-------------------------------------------------------------------------------
--
'Written by Aaron A. Anderson
'
'Use this code however you see fit.  If you modify it to do something cool,
'please send me the changes, so we can share it with everyone.
'
'To use this object, implement the IXMLPropertyBag interface in your
'classes, then add the appropriate code to the ReadProperties and
 WriteProperties
'methods.
'
'Call PropertyBag.SaveState(YourObject) to capture your object state.
'The Contents property then returns the XML containing the captured state, which
'you can persist however you wish (e.g. save it to a file etc)
'
'To restore your object, set the Contents property to the persisted XML and
'then call PropertyBag.RestoreState(YourObject).
'-------------------------------------------------------------------------------
--
'
' Mods:
' 1) Added bin.base64 support for persisting byte arrays
' 2) Added optional Name parameter for saving/restoring - enables multiple
 objects
'    to be persisted to the same XML document
' 3) Added ability to retrieve/set DOMDocument object
' 4) Added <PropertyBag></PropertyBag> as the overall tags around the control
' 5) Modified to use XSL queries to find the nodes rather than enumerating the
'    children
' 6) Added ability to replace (overwrite) existing objects, and to delete
 objects
'
'
 -------------------------------------------------------------------------------
-

Private m_StartNode As MSXML.IXMLDOMNode
Private m_XMLProps As MSXML.DOMDocument

Private Enum epbtTypeConstants
   epbtImplementsPropBag
   epbtEmpty
   epbtNull
   epbtNothing
   epbtByteArray
   epbtDate
   epbtNumber
   epbtString
   epbtStringCData
   epbtError
End Enum

Public Enum epbtErrorConstants
   eeXMLPropertyBagErrorBase = 29450
   eeInvalidVariantType
   eeInvalidXMLFile
End Enum

Private m_sTypeName As String

Private Sub Class_Terminate()

   Set m_StartNode = Nothing
   Set m_XMLProps = Nothing

End Sub

Sub WriteProperty(ByVal PropertyName As String, ByVal PropertyValue As Variant,
 Optional DefaultValue As Variant)

Dim oNode As MSXML.IXMLDOMNode
Dim oClassElement As MSXML.IXMLDOMNode
Dim oTransactionData As XMLPropertyBag
Dim eType As epbtTypeConstants

   
   ' Evaluate the type of variant we are adding to the XML:
   eType = peValidateValueType(PropertyValue)
   
   ' Write out accordingly:
   If eType = epbtError Then
      ' Can't write!
      Err.Raise (vbObjectError + 1048 + eeInvalidVariantType), App.EXEName &
       ".vbalXMLPBag", "Invalid PropertyValue type."
   
   ElseIf eType = epbtImplementsPropBag Then
      ' Must recurse into that property bag implementation:
      Set oTransactionData = New XMLPropertyBag
      ' Prepare the property bag:
      'Ask the object to serialize itself onto a new FCBPropertyBag object
      Set oNode =
       m_StartNode.appendChild(m_StartNode.ownerDocument.createElement(TypeName(
      PropertyValue)))
      IXMLDOMElement(oNode).setAttribute "name", PropertyName
      Set oTransactionData.StartNode = oNode
      IXMLPropertyBag(PropertyValue).WriteProperties oTransactionData
      
   Else
      ' We can write:
      Set oNode =
       m_StartNode.appendChild(m_StartNode.ownerDocument.createElement(PropertyN
      ame))
      
      Select Case eType
      Case epbtDate
         IXMLDOMElement(oNode).Text = PropertyValue
      Case epbtNumber
         IXMLDOMElement(oNode).Text = PropertyValue
      Case epbtString
         IXMLDOMElement(oNode).Text = PropertyValue
      Case epbtStringCData
         Dim cD As IXMLDOMCDATASection
         Set cD = m_StartNode.ownerDocument.createCDATASection(PropertyValue)
         oNode.appendChild cD
      Case epbtByteArray
         With IXMLDOMElement(oNode)
            .dataType = "bin.base64"
            .nodeTypedValue = PropertyValue
         End With
      Case epbtEmpty
         ' Special values:
         IXMLDOMElement(oNode).setAttribute "vartype", "empty"
      Case epbtNothing
         ' Special values:
         IXMLDOMElement(oNode).setAttribute "vartype", "nothing"
      Case epbtNull
         ' Special values:
         IXMLDOMElement(oNode).setAttribute "vartype", "null"
      End Select
   End If

End Sub
Private Function peValidateValueType(Value As Variant) As epbtTypeConstants
   
   ' Here we evaluate what type of variant we're
   ' trying to write out to the XML:
   peValidateValueType = epbtError
   If IsEmpty(Value) Then
      peValidateValueType = epbtEmpty
   ElseIf IsNull(Value) Then
      peValidateValueType = epbtNull
   ElseIf IsObject(Value) Then
      If Value Is Nothing Then
         peValidateValueType = epbtNothing
      ElseIf pbImplementsXMLPropBag(Value) Then
         peValidateValueType = epbtImplementsPropBag
      Else
         ' Evalute for default value.
         peValidateValueType = peGetOtherType(Value)
      End If
   ElseIf IsError(Value) Then
      peValidateValueType = epbtError
   ElseIf IsNumeric(Value) Then
      peValidateValueType = epbtNumber
   ElseIf IsDate(Value) Then
      peValidateValueType = epbtDate
   ElseIf IsArray(Value) Then
      ' only byte arrays are supported:
      If (VarType(Value) And vbByte) = vbByte Then
         peValidateValueType = epbtByteArray
      End If
   Else
      peValidateValueType = peGetOtherType(Value)
   End If
   
End Function
Private Function peGetOtherType(Value As Variant) As epbtTypeConstants
Dim sThis As String
   
   On Error Resume Next
   sThis = Value
   If Err.Number = 0 Then
      peGetOtherType = epbtString
      
      ' Does sThis contain XML delimiters?
      ' NB: rough check.  If you're worried, pass the
      ' information into WriteProperties as a byte
      ' array & the bin.base64 will do its work, then
      ' you'll never have difficulties.
      If Not (InStr(sThis, "<") = 0) Then
         peGetOtherType = epbtStringCData
      ElseIf Not (InStr(sThis, ">") = 0) Then
         peGetOtherType = epbtStringCData
      End If
      
   Else
      peGetOtherType = epbtError
   End If
   Err.Clear
   
End Function
Private Function pbImplementsXMLPropBag(Value As Variant) As epbtTypeConstants
Dim ixpb As IXMLPropertyBag

   On Error Resume Next
   Set ixpb = Value
   pbImplementsXMLPropBag = (Err.Number = 0)
   Err.Clear
   
End Function

Function ReadProperty(PropertyName As String, Optional DefaultValue As Variant)
 As Variant

Dim oTransactionData As XMLPropertyBag
Dim Value As Variant
Dim oNode As MSXML.IXMLDOMNode
Dim oAtt  As MSXML.IXMLDOMAttribute
Dim sQuery As String
Dim bFound As Boolean
Dim oRes As IXMLDOMNodeList
Dim sTypeName As String

   If pbImplementsXMLPropBag(DefaultValue) Then
      sTypeName = m_sTypeName & "/" & TypeName(DefaultValue) & "[@name = """ &
       PropertyName & """]"
      sQuery = "//" & sTypeName
      Set oRes = m_StartNode.selectNodes(sQuery)
      If oRes.length > 0 Then
         Set oTransactionData = New XMLPropertyBag
         Set oNode = oRes(0)
         Set oTransactionData.StartNode = oNode
         oTransactionData.TransTypeName = sTypeName
         IXMLPropertyBag(DefaultValue).ReadProperties oTransactionData
      End If
   Else
      ReadProperty = DefaultValue
         
      sQuery = "//" & m_sTypeName & "/" & PropertyName
      Set oRes = m_StartNode.selectNodes(sQuery)
      If oRes.length > 0 Then
         Set oNode = oRes(0)
         If oNode.dataType = "bin.base64" Then
            ReadProperty = oNode.nodeTypedValue
         Else
            ReadProperty = oNode.Text
         End If
      End If
   End If
   
End Function

Public Sub SaveState(ByVal RootObject As IXMLPropertyBag, Optional ByVal sName
 As String)
Dim sQuery As String
Dim oRes As IXMLDOMNodeList
Dim oPBagElement As MSXML.IXMLDOMNode
Dim oElement As MSXML.IXMLDOMNode
Dim oClassElement As MSXML.IXMLDOMNode
   
   If Not RootObject Is Nothing Then
   
      ' Ensure the document is available:
      If m_XMLProps Is Nothing Then
         Set m_XMLProps = New MSXML.DOMDocument
      End If
      ' Make sure the root tag is present:
      sQuery = "//PropertyBag"
      Set oRes = m_XMLProps.selectNodes(sQuery)
      If oRes.length = 0 Then
         Set oPBagElement =
          m_XMLProps.appendChild(m_XMLProps.createElement("PropertyBag"))
      Else
         Set oPBagElement = oRes.Item(0)
      End If
      
      m_sTypeName = TypeName(RootObject)
      Set oElement = m_XMLProps.createElement(m_sTypeName)
      If Len(sName) > 0 Then
         IXMLDOMElement(oElement).setAttribute "name", sName
      End If
      sQuery = sQuery & "/" & m_sTypeName & ""
      If Len(sName) > 0 Then
         sQuery = sQuery & "[@name=""" & sName & """]"
      End If
      Set oRes = m_XMLProps.selectNodes(sQuery)
      If oRes.length = 0 Then
         ' Need a new element:
         Set oClassElement = IXMLDOMElement(oPBagElement).appendChild(oElement)
      Else
         ' replace
         Set oClassElement =
          IXMLDOMElement(oPBagElement).replaceChild(oElement,
          IXMLDOMElement(oRes.Item(0)))
         Set oClassElement = oElement
      End If
      
      Set m_StartNode = oClassElement
      RootObject.WriteProperties Me
      
   End If
   
End Sub

Public Sub RestoreState(ByVal RootObject As IXMLPropertyBag, Optional ByVal
 sName As String = "")
'
'Starts the process of restoring the object hierarchy
'
Dim sQuery As String
Dim oRes As IXMLDOMNodeList

   m_sTypeName = "PropertyBag/" & TypeName(RootObject)
   If Len(sName) > 0 Then
      m_sTypeName = m_sTypeName & "[@name=""" & sName & """]"
   End If
   
   sQuery = "//" & m_sTypeName
   Set oRes = m_XMLProps.selectNodes(sQuery)
   If oRes.length > 0 Then
      Set m_StartNode = oRes.Item(0)
      RootObject.ReadProperties Me
   End If
   
End Sub

Public Sub DeleteObject(ByVal sTypeName As String, Optional ByVal sName As
 String = "")
Dim sQuery As String
Dim oRes As IXMLDOMNodeList
Dim oClassElement As IXMLDOMNode
Dim oRemove As IXMLDOMNode

   m_sTypeName = "PropertyBag/" & sTypeName
   If Len(sName) > 0 Then
      m_sTypeName = m_sTypeName & "[@name=""" & sName & """]"
   End If
   
   sQuery = "//" & m_sTypeName
   Set oRes = m_XMLProps.selectNodes(sQuery)
   If oRes.length > 0 Then
      Set oRemove = oRes.Item(0)
      sQuery = "//PropertyBag"
      Set oRes = m_XMLProps.selectNodes(sQuery)
      IXMLDOMElement(oRes.Item(0)).removeChild oRemove
   End If
End Sub

Friend Property Let TransTypeName(ByVal sTypeName As String)
   m_sTypeName = sTypeName
End Property

Friend Property Set StartNode(ByVal Node As MSXML.IXMLDOMNode)
   Set m_StartNode = Node
   Set m_XMLProps = m_StartNode.ownerDocument
End Property

Friend Property Get StartNode() As MSXML.IXMLDOMNode
   Set StartNode = m_StartNode
End Property

Public Property Let Contents(ByVal sXML As String)
   Set m_XMLProps = New MSXML.DOMDocument
   If Not m_XMLProps.loadXML(sXML) Then
      ' need to raise an error!
      Err.Raise (vbObjectError + 1048 + eeInvalidXMLFile), App.EXEName &
       ".vbalXMLPBag", m_XMLProps.parseError.reason
   End If
End Property

Public Property Get Contents() As String
   If Not m_XMLProps Is Nothing Then
      Contents = m_XMLProps.xml
   End If
End Property

Public Property Get Document() As DOMDocument
   Set Document = m_XMLProps
End Property
Public Property Let Document(oDoc As DOMDocument)
   Set m_XMLProps = oDoc
End Property

Private Function IXMLDOMElement(ByVal Node As IXMLDOMNode) As IXMLDOMElement
   Set IXMLDOMElement = Node
End Function

Private Function IXMLPropertyBag(ByVal Source As IXMLPropertyBag) As
 IXMLPropertyBag
   Set IXMLPropertyBag = Source
End Function

Private Function AttributeValue( _
      ByVal Node As MSXML.IXMLDOMNode, _
      ByVal sAttributeName As String, _
      Optional ByVal vDefault As Variant = Empty _
   ) As Variant
   If Not IXMLDOMElement(m_StartNode).getAttributeNode(sAttributeName) Is
    Nothing Then
      AttributeValue = IXMLDOMElement(m_StartNode).getAttribute(sAttributeName)
   Else
      AttributeValue = vDefault
   End If
End Function