xml操作类（转载）

作者：未知  请与本人联系ClassXMLDOMDocument PrivatefNode

作者：未知   请与本人联系 <% 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 %>

本文由来源 21aspnet，由 javajgs_com 整理编辑，其版权均为 21aspnet 所有，文章内容系作者个人观点，不代表 Java架构师必看 对观点赞同或支持。如需转载，请注明文章来源。