<% Class XMLDOMDocument Private fNode, fANode Private fErrInfo, fFileName, fOpen Dim 'return node indent string Private XmlDom 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 'to return a child node object, ElementOBJ parent node, the node ChildNodeObj're looking for, IsAttributeNode indicate whether the attribute object 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 (CHILDEOBJ)) = "String" and Trim (ChildNodeObj) <> "" "" THENTOBJ) THEN SET ELEMENT = fnode elseif lcase (TypenAme (Elementobj)) = "String" THEN IF TRIM (EL ementOBJ) <> "" 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 'read the last error Public Property Get ErrInfo ErrInfo = fErrInfo End Property' xml content to 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 '============== ============================================================================================================================================================================================================= = 'class initialization 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 class release SUB class_terminate () set fnode = nothing set fanode = nothing set xmldom = ================================================================== ===================================================07018705 Name name.
XSLURL: using XSL style addresses' returns root 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 'war XML file that already exists, return to open Function open (byVal xmlSourceFile) open = false xmlSourceFile = Trim (xmlSourceFile) If xmlSourceFile = "" Then Exit Function XmlDom.async = false XmlDom.load xmlSourceFile FFileName = XmlsourceFile if not isrror thrue fope n = true end if end function 'Close Sub Close () set fnode = Nothing set fanode = Nothing ferrinfo = "" ffilename = "" FOPEN = false end sub' read a nodeobj node text "NodeObj can be a node object or node name is null to take the current default 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" the set fnode = NodeObj else set fanode = nodeobj end if getnodetext = nodeobj.text end function 'inserted in Befeelementobj, one named ElementName, Value as ElementText.
'Isfirst: Is it in the first position; Iscdata: Note if the value of the node belongs to the CDATA type' Insert a new insertion This node 'beFelementObj can be an object or a null name, take the current default object Function InsertErtelement (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. Appendc hild 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 'Insert or modifies at the ELEMENTOBJ node, the value of attributename, the value: attributeText' If there is already a attribute object called AttributeName, modify it.
'Back insert or modify the properties of the Node' ElementOBJ may be an Element object or name, a null would take the current default object 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 'Review Text value ElementOBJ node, and returns the node' ElementOBJ be objects or object name is null to take the current default object Function UpdateNodeText (byVal ElementOBJ, byVal NEWELEMENTTEXT, BYVAL ISCDATA) DIM TEXTSECTION SET UPDATENODETEXT = Nothing if not fopen1 exit function set elementobj = childNode (xmldom, elementobj, false) i f 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 'Returns the first ElementNode that matches the TestValue condition,
Is null to take the current default object 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 'to delete a child node 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" the if elementobj is fnode the 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 'Clear all child nodes of a node 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 'delete child an attribute node 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 the elementobj.removeattributenode (AttributeObj) Removeat TRIBUTENODE = TRUE End If End Function 'Saves Opened File, as long as FileName does not empty, you can save Function Save () on error resume next save = false = ") or (ffilename =") THEN EXIT FUNCTION Xmldom.save ffilename save = (not isrror) if err.number <> 0 Then Err.CLEAR SAVE = false end if End function 'Save as an XML file, as long as FileName does not empty, you can save Function Saveas (SaveFileName) on Error Resume Next SaveAs = false if (not fopen) or savefilename = "" "The exit function xmldom.save savefilename saveas = (not isrror) if err.Number <> 0 Then Err.clear saveas =
