cdomfunctions.cls

用XML做专家系统的一个编译器,有说明书,使用简单,有模板

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDomFunctions"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'***************************************************************************
' Class to demonstrate using the DOM in VB, and to provide
' DOM wrapper functions to simplify manipulating nodes
' Some observations:
' The DOC_TYPE node does not expose its contents as child nodes.
' You can inspect the entities by explicity looking at them, etc.,
' but you will not see the ELEMENT or ATTLIST  text unless you
' get the XML from the node.
' The DOM spec states:
' "Each Document has a doctype attribute whose value is either null
' or a DocumentType object. The DocumentType interface in the DOM Level 1
' Core provides an interface to the list of entities that are defined for
' the document, and little else because the effect of namespaces and the
' various XML scheme efforts on DTD representation are not clearly understood
' as of this writing. The DOM Level 1 doesn't support editing DocumentType nodes."

'***************************************************************************
Option Explicit
Public Enum DOMException
    NO_ERROR = 0
    INDEX_SIZE_ERR = 1
    DOMSTRING_SIZE_ERR = 2
    HIERARCHY_REQUEST_ERR = 3
    WRONG_DOCUMENT_ERR = 4
    INVALID_CHARACTER_ERR = 5
    NO_DATA_ALLOWED_ERR = 6
    NO_MODIFICATION_ALLOWED_ERR = 7
    NOT_FOUND_ERR = 8
    NOT_SUPPORTED_ERR = 9
    INUSE_ATTRIBUTE_ERR = 10
    UNKNOWN = 99
End Enum

Public Enum NodeType
    NODE_INVALID = 0
    NODE_ELEMENT = 1
    NODE_ATTRIBUTE = 2
    NODE_TEXT = 3
    NODE_CDATA_SECTION = 4
    NODE_ENTITY_REFERENCE = 5
    NODE_ENTITY = 6
    NODE_PROCESSING_INSTRUCTION = 7
    NODE_COMMENT = 8
    NODE_DOCUMENT = 9
    NODE_DOCUMENT_TYPE = 10
    NODE_DOCUMENT_FRAGMENT = 11
    NODE_NOTATION = 12
End Enum

Const domerrNO_ERROR As Integer = 0
Const domerrINDEX_SIZE_ERR As Integer = 1
Const domerrDOMSTRING_SIZE_ERR  As Integer = 2
Const domerrHIERARCHY_REQUEST_ERR  As Integer = 3
Const domerrWRONG_DOCUMENT_ERR  As Integer = 4
Const domerrINVALID_CHARACTER_ERR As Integer = 5
Const domerrNO_DATA_ALLOWED_ERR As Integer = 6
Const domerrNO_MODIFICATION_ALLOWED_ERR  As Integer = 7
Const domerrNOT_FOUND_ERR  As Integer = 8
Const domerrNOT_SUPPORTED_ERR  As Integer = 9
Const domerrINUSE_ATTRIBUTE_ERR  As Integer = 10
Const domerrUNKNOWN As Integer = 99

Private m_strErrorDescription As String
Private m_lngErrorNumber As Long
Private m_strErrorSource As String
Private m_DomError As DOMException

Public Property Get ErrorDescription() As String
    ErrorDescription = m_strErrorDescription
End Property
Public Property Get domError() As DOMException
    domError = m_DomError
End Property

Public Property Get ErrorNumber() As Long
    ErrorNumber = m_lngErrorNumber
End Property
Public Property Get ErrorSource() As String
    ErrorSource = m_strErrorSource
End Property

'***************************************************************************
' Public Function AddAttribute(oDOM As DOMDocument,
'                            oElement As IXMLDOMElement,
'                            sName As String,
'                            sValue As String
'                            ) As Boolean
'
'***************************************************************************
Public Function AddAttribute(oDOM As DOMDocument, _
                            oElement As IXMLDOMElement, _
                            sName As String, _
                            sValue As String, _
                            Optional bReplace As Boolean = False _
                            ) As Boolean
    On Error GoTo ErrHand
    
    Dim oAttr As IXMLDOMAttribute
    Dim bResults As Boolean
    
    Call ClearErrorInfo
    ' First see if the attribute already exists ...
    If (Not oElement.Attributes.getNamedItem(sName) Is Nothing) Then
        If bReplace = False Then
            bResults = False
        End If
    Else
        Set oAttr = oDOM.createAttribute(sName)
        oElement.setAttribute sName, sValue
        oElement.setAttribute sName, sValue
        bResults = True
    End If
    
ErrHand:
    If Err.Number <> 0 Then
        Call SetErrorInfo(Err.Number, Err.Description, "CDomFunctions." & Err.Source, UNKNOWN)
        bResults = False
    End If
    
    AddAttribute = bResults
End Function

'***************************************************************************
' Public Function AddCDATA(oDOM As DOMDocument,
'                     oPNode As IXMLDOMNode,
'                     sElementContent As String
'                     ) As Boolean
'
'***************************************************************************
Public Function AddCDATA(oDOM As DOMDocument, _
                    oPNode As IXMLDOMNode, _
                    sCDATAContent As String _
                    ) As Boolean
    On Error GoTo ErrHand
    
    Dim oNode As MSXML.IXMLDOMNode
    Dim elNode As MSXML.IXMLDOMCDATASection
    Dim bResults As Boolean
    
    Call ClearErrorInfo
    ' <![CDATA[<greeting>Hello, world!</greeting>]]>
    ' We need to check that the string we're assigning to the
    ' CDATA section doesn't contain the "end of CDATA section"
    ' character combo: ]]>
    If (InStr(sCDATAContent, "]]>")) Then
        bResults = False
        Call SetErrorInfo(-1, "Invalid character string: ']]>' ", _
            "CDomFunctions.AddCDATA", INVALID_CHARACTER_ERR)
    Else
        Select Case oPNode.NodeType
            Case NODE_DOCUMENT_FRAGMENT, NODE_ENTITY_REFERENCE, NODE_ELEMENT:
                Set elNode = oDOM.createCDATASection(sCDATAContent)
                oPNode.appendChild elNode
                bResults = True
            Case Else
                bResults = False
                Call SetErrorInfo(-1, "Invalid parent node type.", _
                    "CDomFunctions.AddCDATA", HIERARCHY_REQUEST_ERR)
        End Select
    End If
    
ErrHand:
    If Err.Number <> 0 Then
        Call SetErrorInfo(Err.Number, Err.Description, "CDomFunctions." & Err.Source, UNKNOWN)
        bResults = False
    End If
    AddCDATA = bResults
End Function
Public Function AddComment(oDOM As DOMDocument, _
                    oPNode As IXMLDOMNode, _
                    sContent As String _
                    ) As Boolean
    On Error GoTo ErrHand
    
    Dim oNode As MSXML.IXMLDOMNode
    Dim elNode As MSXML.IXMLDOMComment
    Dim bResults As Boolean
    
    Call ClearErrorInfo

    Select Case oPNode.NodeType
        Case NODE_DOCUMENT_FRAGMENT, NODE_DOCUMENT, NODE_ENTITY_REFERENCE, NODE_ELEMENT:
            Set elNode = oDOM.createComment(sContent)
            oPNode.appendChild elNode
            bResults = True
        Case Else
            bResults = False
            Call SetErrorInfo(-1, "Invalid parent node type.", "CDomFunctions.AddComment", HIERARCHY_REQUEST_ERR)
    End Select
    
ErrHand:
    If Err.Number <> 0 Then
        Call SetErrorInfo(Err.Number, Err.Description, "CDomFunctions." & Err.Source, UNKNOWN)
        bResults = False
    End If

    AddComment = bResults

End Function

Public Function AddElement(oDOM As DOMDocument, _
                    oPNode As IXMLDOMNode, _
                    sElementName As String, _
                    sElementContent As String _
                    ) As Boolean
    On Error GoTo ErrHand
    
    Dim oNode As MSXML.IXMLDOMNode
    Dim elNode As MSXML.IXMLDOMElement
    Dim bResults As Boolean
    
    Call ClearErrorInfo
    ' Need to check that the element name is valid
    If Not ValidateElementType(sElementName) Then
        AddElement = False
        Call SetErrorInfo(-1, "Invalid element type", _
            "CDomFunctions.AddElement", INVALID_CHARACTER_ERR)
        bResults = False
    Else
        Select Case oPNode.NodeType
            Case NODE_DOCUMENT, NODE_DOCUMENT_FRAGMENT, _
                NODE_ENTITY_REFERENCE, NODE_ELEMENT:
                Set elNode = oDOM.createElement(sElementName)
                Set oNode = oPNode.appendChild(elNode)
                If (Len(sElementContent)) Then
                    oNode.Text = sElementContent
                End If
                bResults = True
            Case Else
                bResults = False
                Call SetErrorInfo(-1, "Invalid parent node type.", _
                    "CDomFunctions.AddElement", HIERARCHY_REQUEST_ERR)
        End Select
    End If

ErrHand:
    If Err.Number <> 0 Then
        bResults = False
        Call SetErrorInfo(Err.Number, Err.Description, "CDomFunctions." & Err.Source, UNKNOWN)
    End If
    
    AddElement = bResults
End Function

Public Function AddElementXML(oDOM As DOMDocument, _
                    oPNode As IXMLDOMNode, _
                    sElementXML As String _
                    ) As Boolean
    On Error GoTo ErrHand
    
    Dim oNode As MSXML.IXMLDOMNode
    Dim elNode As MSXML.IXMLDOMElement
    Dim oTempDOM As DOMDocument
    Dim nIdx As Integer
    Dim strParserErr As String
    Dim domErr As DOMException
    
    Call ClearErrorInfo
    
    Set oTempDOM = New DOMDocument
    If Not (oTempDOM.loadXML(sElementXML)) Then
        AddElementXML = False
        strParserErr = oTempDOM.parseError.reason
        If InStr(strParserErr, "name was started with an invalid character") Then
            domErr = INVALID_CHARACTER_ERR
        Else
            domErr = UNKNOWN
        End If
        Call SetErrorInfo(-1, "Invalid element XML: " & strParserErr, _
            "CDomFunctions.AddElementXML", domErr)
        AddElementXML = False
        Exit Function
    End If
    
    Select Case oPNode.NodeType
        Case NODE_DOCUMENT, NODE_DOCUMENT_FRAGMENT, NODE_ENTITY_REFERENCE, NODE_ELEMENT:
            Set elNode = oDOM.createElement(oTempDOM.documentElement.nodeName)
            Set oNode = oPNode.appendChild(elNode)
            If (Len(oTempDOM.documentElement.Text)) Then
                oNode.Text = oTempDOM.documentElement.Text
            End If
            If (oTempDOM.documentElement.Attributes.length > 0) Then
                With oTempDOM.documentElement.Attributes
                  For nIdx = 0 To oTempDOM.documentElement.Attributes.length - 1
                    If Not (AddAttribute(oDOM, oNode, .Item(nIdx).nodeName, .Item(nIdx).nodeValue)) Then
                      AddElementXML = False
                      Call SetErrorInfo(-1, "Error adding attribute.", "CDomFunctions.AddElementXML", UNKNOWN)
                      Exit Function
                    End If
                  Next
                End With
            End If
            AddElementXML = True
        Case Else
            AddElementXML = False
            Call SetErrorInfo(-1, "Invalid parent node type.", "CDomFunctions.AddElementXML", UNKNOWN)
    End Select
    
ErrHand:
    If Err.Number <> 0 Then
    AddElementXML = False
        Call SetErrorInfo(Err.Number, Err.Description, "CDomFunctions." & Err.Source, UNKNOWN)
    End If
End Function

Public Function AddEntity(oDOM As DOMDocument, _
                            oPNode As IXMLDOMNode, _
                            sEntity As String _
                            ) As Boolean
    On Error GoTo ErrHand
    ' You cannot create a node of type NODE_DOCUMENT,
    ' NODE_DOCUMENT_TYPE,
    ' NODE_ENTITY, or
    ' NODE_NOTATION.
    
    Dim oNode As MSXML.IXMLDOMNode
    Dim elNode As MSXML.IXMLDOMEntity

    Call ClearErrorInfo
    
    Select Case oPNode.NodeType