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 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 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&"Reason :"&XmlDom.ParseError.reason&" "

fErrInfo=fErrInfo&"URL    :"&XmlDom.ParseError.url&" "

fErrInfo=fErrInfo&"Line   :"&XmlDom.ParseError.line&" "

fErrInfo=fErrInfo&"FilePos:"&XmlDom.ParseError.filepos&" "

fErrInfo=fErrInfo&"srcText:"&XmlDom.ParseError.srcText&" "

IsError=True

Else

IsError=False

End If

End Function

End Class