XML操作类

<%
Class XMLDOMDocument
  Private fNode,fANode
  Private fErrInfo,fFileName,fOpen
  Dim XmlDom
 
  '返回节点的缩进字串
  Private Property Get TabStr(byVal Node)
    TabStr=""
    If Node Is Nothing Then Exit Property
    If not Node.parentNode Is nothing Then TabStr="  "&TabStr(Node.parentNode)
  End Property
 
  '返回一个子节点对象,ElementOBJ为父节点,ChildNodeObj要查找的节点,IsAttributeNode指出是否为属性对象
  Public Property Get ChildNode(byVal ElementOBJ,byVal ChildNodeObj,byVal IsAttributeNode)
    Dim Element
    Set ChildNode=Nothing
       
    If IsNull(ChildNodeObj) Then
      If IsAttributeNode=false Then
        Set ChildNode=fNode
      Else
        Set ChildNode=fANode
      End If
      Exit Property
    ElseIf IsObject(ChildNodeObj) Then
      Set ChildNode=ChildNodeObj
      Exit Property
    End If
   
    Set Element=Nothing
    If LCase(TypeName(ChildNodeObj))="string" and Trim(ChildNodeObj)<>"" Then
      If IsNull(ElementOBJ) Then
         Set Element=fNode
      ElseIf LCase(TypeName(ElementOBJ))="string" Then
         If Trim(ElementOBJ)<>"" Then
           Set Element=XmlDom.selectSingleNode("//"&Trim(ElementOBJ))
           If Lcase(Element.nodeTypeString)="attribute" Then Set Element=Element.selectSingleNode("..")
         End If
      ElseIf IsObject(ElementOBJ) Then
         Set Element=ElementOBJ
      End If
     
      If Element Is Nothing Then
        Set ChildNode=XmlDom.selectSingleNode("//"&Trim(ChildNodeObj))
      ElseIf IsAttributeNode=true Then
        Set ChildNode=Element.selectSingleNode("./@"&Trim(ChildNodeObj))
      Else
        Set ChildNode=Element.selectSingleNode("./"&Trim(ChildNodeObj))
      End If
    End If
  End Property
 
  '读取最后的错误信息
  Public Property Get ErrInfo
    ErrInfo=fErrInfo
  End Property

  '给xml内容
  Public Property Get xmlText(byVal ElementOBJ)
    xmlText=""
    If fopen=false Then Exit Property
   
    Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
    If ElementOBJ Is Nothing Then Set ElementOBJ=XmlDom

    xmlText=ElementOBJ.xml
  End Property
 
  '=================================================================
  '类初始化
  Private Sub Class_Initialize()
    Set XmlDom=CreateObject("Microsoft.XMLDOM")
    XmlDom.preserveWhiteSpace=true
   
    Set fNode=Nothing
    Set fANode=Nothing

    fErrInfo=""
    fFileName=""
    fopen=false
  End Sub

  '类释放
  Private Sub Class_Terminate()
    Set fNode=Nothing
    Set fANode=Nothing
    Set XmlDom=nothing
    fopen=false
  End Sub
 
  '=====================================================================
  '建立一个XML文件，RootElementName：根结点名。XSLURL：使用XSL样式地址
  '返回根结点
  Function Create(byVal RootElementName,byVal XslUrl)
    Dim PINode,RootElement
   
    Set Create=Nothing
   
    If (XmlDom Is Nothing) Or (fopen=true) Then Exit Function
   
    If Trim(RootElementName)="" Then RootElementName="Root"
   
    Set PINode=XmlDom.CreateProcessingInstruction("xml", "version=""1.0""  encoding=""GB2312""")
    XmlDom.appendChild PINode

    Set PINode=XMLDOM.CreateProcessingInstruction("xml-stylesheet", "type=""text/xsl"" href="""&XslUrl&"""")
    XmlDom.appendChild PINode

    Set RootElement=XmlDom.createElement(Trim(RootElementName))
    XmlDom.appendChild RootElement
   
    Set Create=RootElement
   
    fopen=True
    set fNode=RootElement
  End Function
 
  '开打一个已经存在的XML文件,返回打开状态
  Function Open(byVal xmlSourceFile)
    Open=false
   
    xmlSourceFile=Trim(xmlSourceFile)
    If xmlSourceFile="" Then Exit Function

    XmlDom.async = false
    XmlDom.load xmlSourceFile
   
    fFileName=xmlSourceFile

    If not IsError Then
       Open=true
       fopen=true
    End If
  End Function
 
  '关闭
  Sub Close()
    Set fNode=Nothing
    Set fANode=Nothing

    fErrInfo=""
    fFileName=""
    fopen=false
  End Sub
 
  '读取一个NodeOBJ的节点Text的值
  'NodeOBJ可以是节点对象或节点名，为null就取当前默认fNode
  Function getNodeText(byVal NodeOBJ)
    getNodeText=""
    If fopen=false Then Exit Function
   
    Set NodeOBJ=ChildNode(null,NodeOBJ,false)
    If NodeOBJ Is Nothing Then Exit Function

    If Lcase(NodeOBJ.nodeTypeString)="element" Then
      set fNode=NodeOBJ
    Else
      set fANode=NodeOBJ
    End If
    getNodeText=NodeOBJ.text
  End function
 
  '插入在BefelementOBJ下面一个名为ElementName，Value为ElementText的子节点。
  'IsFirst：是否插在第一个位置；IsCDATA：说明节点的值是否属于CDATA类型
  '插入成功就返回新插入这个节点
  'BefelementOBJ可以是对象也可以是节点名，为null就取当前默认对象
  Function InsertElement(byVal BefelementOBJ,byVal ElementName,byVal ElementText,byVal IsFirst,byVal IsCDATA)
    Dim Element,TextSection,SpaceStr
    Set InsertElement=Nothing
   
    If not fopen Then Exit Function

    Set BefelementOBJ=ChildNode(XmlDom,BefelementOBJ,false)
    If BefelementOBJ Is Nothing Then Exit Function
   
    Set Element=XmlDom.CreateElement(Trim(ElementName))
   
    'SpaceStr=vbCrLf&TabStr(BefelementOBJ)
    'Set STabStr=XmlDom.CreateTextNode(SpaceStr)
   
    'If Len(SpaceStr)>2 Then  SpaceStr=Left(SpaceStr,Len(SpaceStr)-2)
    'Set ETabStr=XmlDom.CreateTextNode(SpaceStr)
   
    If IsFirst=true Then
      'BefelementOBJ.InsertBefore ETabStr,BefelementOBJ.firstchild
      BefelementOBJ.InsertBefore Element,BefelementOBJ.firstchild
      'BefelementOBJ.InsertBefore STabStr,BefelementOBJ.firstchild
    Else
      'BefelementOBJ.appendChild STabStr
      BefelementOBJ.appendChild Element
      'BefelementOBJ.appendChild ETabStr
    End If

    If IsCDATA=true Then
      set TextSection=XmlDom.createCDATASection(ElementText)
      Element.appendChild TextSection
    ElseIf ElementText<>"" Then
      Element.Text=ElementText
    End If

    Set InsertElement=Element
    Set fNode=Element
  End Function
 
  '在ElementOBJ节点上插入或修改名为AttributeName，值为：AttributeText的属性
  '如果已经存在名为AttributeName的属性对象，就进行修改。
  '返回插入或修改属性的Node
  'ElementOBJ可以是Element对象或名，为null就取当前默认对象
  Function setAttributeNode(byVal ElementOBJ,byVal AttributeName,byVal AttributeText)
    Dim AttributeNode
    Set setAttributeNode=nothing

    If not fopen Then Exit Function
  
    Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
    If ElementOBJ Is Nothing Then Exit Function
  
    Set AttributeNode=ElementOBJ.attributes.getNamedItem(AttributeName)
    If AttributeNode Is nothing Then
       Set AttributeNode=XmlDom.CreateAttribute(AttributeName)
       ElementOBJ.setAttributeNode AttributeNode
    End If
    AttributeNode.text=AttributeText
   
    set fNode=ElementOBJ
    set fANode=AttributeNode
    Set setAttributeNode=AttributeNode
  End Function
 
  '修改ElementOBJ节点的Text值，并返回这个节点
  'ElementOBJ可以对象或对象名，为null就取当前默认对象
  Function UpdateNodeText(byVal ElementOBJ,byVal NewElementText,byVal IsCDATA)
    Dim TextSection

    set UpdateNodeText=nothing
    If not fopen Then Exit Function
   
    Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
    If ElementOBJ Is Nothing Then Exit Function

    If IsCDATA=true Then
      set TextSection=XmlDom.createCDATASection(NewElementText)
      If ElementOBJ.firstchild Is Nothing Then
        ElementOBJ.appendChild TextSection
      ElseIf LCase(ElementOBJ.firstchild.nodeTypeString)="cdatasection" Then
        ElementOBJ.replaceChild TextSection,ElementOBJ.firstchild
      End If
    Else
      ElementOBJ.Text=NewElementText
    End If
   
    set fNode=ElementOBJ
    Set UpdateNodeText=ElementOBJ
  End Function
 
  '返回符合testValue条件的第一个ElementNode，为null就取当前默认对象
  Function getElementNode(byVal ElementName,byVal testValue)
    Dim Element,regEx,baseName
   
    Set getElementNode=nothing
    If not fopen Then Exit Function

    testValue=Trim(testValue)
    Set regEx=New RegExp
    regEx.Pattern="^[A-Za-z]+"
    regEx.IgnoreCase=true
    If regEx.Test(testValue) Then testValue="/"&testValue
    Set regEx=nothing
   
    baseName=LCase(Right(ElementName,Len(ElementName)-InStrRev(ElementName,"/",-1)))

    Set Element=XmlDom.SelectSingleNode("//"&ElementName&testValue)

    If Element Is Nothing Then
      'Response.write ElementName&testValue
      Set getElementNode=nothing
      Exit Function
    End If

    Do While LCase(Element.baseName)<>baseName
      Set Element=Element.selectSingleNode("..")
      If Element Is Nothing Then Exit Do
    Loop
       
    If LCase(Element.baseName)<>baseName Then
      Set getElementNode=nothing
    Else
      Set getElementNode=Element
      If Lcase(Element.nodeTypeString)="element" Then
        Set fNode=Element
      Else
        Set fANode=Element
      End If
    End If
  End Function
 
  '删除一个子节点
  Function removeChild(byVal ElementOBJ)
    removeChild=false
    If not fopen Then Exit Function

    Set ElementOBJ=ChildNode(null,ElementOBJ,false)
    If ElementOBJ Is Nothing Then Exit Function
   
    'response.write ElementOBJ.baseName

    If Lcase(ElementOBJ.nodeTypeString)="element" Then
      If ElementOBJ Is fNode Then set fNode=Nothing
      If ElementOBJ.parentNode Is Nothing Then
        XmlDom.removeChild(ElementOBJ)
      Else
        ElementOBJ.parentNode.removeChild(ElementOBJ)
      End If
      removeChild=True
    End If
  End Function
 
  '清空一个节点所有子节点
  Function ClearNode(byVal ElementOBJ)
     set ClearNode=Nothing
     If not fopen Then Exit Function
   
     Set ElementOBJ=ChildNode(null,ElementOBJ,false)
     If ElementOBJ Is Nothing Then Exit Function
    
     ElementOBJ.text=""
     ElementOBJ.removeChild(ElementOBJ.firstchild)
    
     Set ClearNode=ElementOBJ
     Set fNode=ElementOBJ
  End Function

  '删除子节点的一个属性
  Function removeAttributeNode(byVal ElementOBJ,byVal AttributeOBJ)
    removeAttributeNode=false
    If not fopen Then Exit Function
   
    Set ElementOBJ=ChildNode(XmlDom,ElementOBJ,false)
    If ElementOBJ Is Nothing Then Exit Function
   
    Set AttributeOBJ=ChildNode(ElementOBJ,AttributeOBJ,true)
    If not AttributeOBJ Is nothing Then
      ElementOBJ.removeAttributeNode(AttributeOBJ)
      removeAttributeNode=True
    End If
  End Function

  '保存打开过的文件，只要保证FileName不为空就可以实现保存
  Function Save()
    On Error Resume Next
    Save=false
    If (not fopen) or (fFileName="") Then Exit Function
   
    XmlDom.Save fFileName
    Save=(not IsError)
    If Err.number<>0 then
      Err.clear
      Save=false
    End If
  End Function

  '另存为XML文件，只要保证FileName不为空就可以实现保存
  Function SaveAs(SaveFileName)
    On Error Resume Next
    SaveAs=false
    If (not fopen) or SaveFileName="" Then Exit Function
    XmlDom.Save SaveFileName
    SaveAs=(not IsError)
    If Err.number<>0 then
      Err.clear
      SaveAs=false
    End If
  End Function

  '检查并打印错误信息
  Private Function IsError()
    If XmlDom.ParseError.errorcode<>0 Then
       fErrInfo="<h1>Error"&XmlDom.ParseError.errorcode&"</h1>"
       fErrInfo=fErrInfo&"<B>Reason :</B>"&XmlDom.ParseError.reason&"<br>"
       fErrInfo=fErrInfo&"<B>URL &nbsp; &nbsp;:</B>"&XmlDom.ParseError.url&"<br>"
       fErrInfo=fErrInfo&"<B>Line &nbsp; :</B>"&XmlDom.ParseError.line&"<br>"
       fErrInfo=fErrInfo&"<B>FilePos:</B>"&XmlDom.ParseError.filepos&"<br>"
       fErrInfo=fErrInfo&"<B>srcText:</B>"&XmlDom.ParseError.srcText&"<br>"
       IsError=True
    Else
      IsError=False
    End If
  End Function
End Class
%>

本文地址：http://com.8s8s.com/it/it43826.htm