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
% >