br>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 E
lementOBJ=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 :</B>"&XMLDom.ParseError.url&"<br>"
fErrInfo=fErrInfo&"<B>Line :</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
%>