学习XML和VBSCLASS的优秀实例_vbs class listex-CSDN博客

'***************************************************
' 说明：Person类
' 作者：gwd 2002-11-06
' 引用：pub/constpub.asp
'***************************************************

Class Cls_Person
    Private m_intId      ' Id，对应Person节点在Persons集合中的位置
    Private m_strName    ' 姓名
    Private m_strNick    ' 英文名
    Private m_strMobile ' 手机
    Private m_strTel     ' 电话
    Private m_strEmail   ' 电子邮件
    Private m_strQQ      ' QQ号
    Private m_strCompany ' 所在公司
    Private m_strError   ' 出错信息

    ' 类初始化
    Private Sub Class_Initialize()
    　m_strError = ""
    　m_intId = -1
    End Sub

    ' 类释放
    Private Sub Class_Terminate()
    　m_strError = ""
    End Sub

'-----读写各个属性---------------------------

    Public Property Get Id
    　Id = m_intId
    End Property

    Public Property Let Id(intId)
    　m_intId = intId
    End Property

    Public Property Get Name
        Name = m_strName
    End Property

    Public Property Let Name(strName)
    　m_strName = strName
    End Property

    Public Property Get Nick
    　Nick = m_strNick
    End Property

    Public Property Let Nick(strNick)
    　m_strNick = strNick
    End Property

    Public Property Get Mobile
    　Mobile = m_strMobile
    End Property

    Public Property Let Mobile(strMobile)
    　m_strMobile = strMobile
    End Property

    Public Property Get Tel
    　Tel = m_strTel
    End Property

    Public Property Let Tel(strTel)
    　m_strTel = strTel
    End Property

    Public Property Get Email
    　Email = m_strEmail
    End Property

    Public Property Let Email(strEmail)
    　m_strEmail = strEmail
    End Property

    Public Property Get QQ
    　QQ = m_strQQ
    End Property

    Public Property Let QQ(strQQ)
    　m_strQQ = strQQ
    End Property

    Public Property Get Company
    　Company = m_strCompany
    End Property

    Public Property Let Company(strCompany)
    　m_strCompany = strCompany
    End Property

'-----------------------------------------------

    ' 获取错误信息
    Public Function GetLastError()
    　GetLastError = m_strError
    End Function

    ' 私有方法，添加错误信息
    Private Sub AddErr(strEcho)
    　m_strError = m_strError + "<Div CLASS=""alert""＞" & strEcho & "</Div＞"
    End Sub

    ' 清除错误信息
    Public Function ClearError()
    　m_strError = ""
    End Function

    ' 从Xml中读取指定节点的数据，并填充各个属性
    ' 需要首先设置Id
    Public Function GetInfoFromXml(objXmlDoc)
    　Dim objNodeList
    　Dim I

　ClearError

    　IF objXmlDoc Is Nothing Then
    　　GetInfoFromXml = False
    　　AddErr "Dom对象为空值"
    　　Exit Function
    　End If

    　IF CStr(m_intId) = "-1" Then
    　　GetInfoFromXml = False
    　　AddErr "未正确设置联系人对象的ID属性"
    　　Exit Function
    　Else
    　　I = m_intId - 1 ' 要读取得节点位置
    　End IF

    　' 选择并读取节点信息，赋予各个属性
    　Set objNodeList = objXmlDoc.getElementsByTagName("Person")
    　IF objNodeList.length - m_intId >= 0 Then
    　　On Error Resume Next
    　　m_strName    = objNodeList(I).selectSingleNode("Name").Text
    　　m_strNick    = objNodeList(I).selectSingleNode("Nick").Text
    　　m_strMobile = objNodeList(I).selectSingleNode("Mobile").Text
    　　m_strTel     = objNodeList(I).selectSingleNode("Tel").Text
    　　m_strEmail   = objNodeList(I).selectSingleNode("Email").Text
    　　m_strQQ      = objNodeList(I).selectSingleNode("QQ").Text
    　　m_strCompany = objNodeList(I).selectSingleNode("Company").Text
    　　GetInfoFromXml = True
    　Else
    　　GetInfoFromXml = False
    　　AddErr "获取联系信息发生错误"
    　　Set objNodeList = Nothing
    　　Exit Function
    　End If
    　Set objNodeList = Nothing
    End Function

    ' 添加信息到XML文件中
    ' 需要首先设置好要填充的属性
    Public Function AddToXml(objXmlDoc)
    　Dim objPerson, objNode

    　ClearError

    　IF objXmlDoc Is Nothing Then
    　　AddToXml = False
    　　AddErr "Dom对象为空值"
    　　Exit Function
    　End If

    　' 创建Person节点
    　Set objPerson = objXmlDoc.createElement("Person")
    　objXmlDoc.documentElement.appendChild objPerson

    　' 创建各个子节点
    　'-----------------------------------------------------
    　Set objNode = objXmlDoc.createElement("Name")
    　objNode.Text = m_strName
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Nick")
    　objNode.Text = m_strNick
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Mobile")
    　objNode.Text = m_strMobile
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Tel")
    　objNode.Text = m_strTel
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Email")
    　objNode.Text = m_strEmail
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("QQ")
    　objNode.Text = m_strQQ
    　objPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Company")
    　objNode.Text = m_strCompany
    　objPerson.appendChild objNode
    　'-----------------------------------------------------

    　Set objNode = Nothing
    　Set objPerson = Nothing

    　On Error Resume Next
    　objXmlDoc.save Server.MapPath(C_XMLFILE) '保存XML文件
    　If Err.Number = 0 Then
    　　AddToXml = True
    　Else
    　　AddToXml = False
    　　AddErr Err.Description
    　End If
    End Function

    ' 从XML文件中删除数据
    ' 需要首先设置Id
    Public Function DeleteFromXml(objXmlDoc)
    　Dim objNodeList, objNode

    　ClearError

    　If objXmlDoc Is Nothing Then
        　　DeleteFromXml = False
    　　AddErr "Dom对象为空值"
    　　Exit Function
    　End If

    　If CStr(m_intId) = "-1" Then
    　　DeleteFromXml = False
    　　AddErr "未正确设置联系人对象的ID属性"
    　　Exit Function
    　End If

    　Set objNodeList = objXmlDoc.getElementsByTagName("Person")
    　If objNodeList.length - m_intId < 0 Then
    　　DeleteFromXml = False
    　　AddErr "未找到相应的联系人"
    　　Set objNodeList = Nothing
    　　Exit Function
    　End If

    　On Error Resume Next
    　Set objNode = objXmlDoc.documentElement.removeChild(objNodeList(intId-1))
    　If objNode Is Nothing Then
    　　DeleteFromXml = False
    　　AddErr "删除联系人失败"
    　　Set objNodeList = Nothing
    　　Exit Function
    　Else
    　　objXmlDoc.save Server.MapPath(C_XMLFILE)
    　End If
    　Set objNode = Nothing
    　Set objNodeList = Nothing

    　If Err.Number = 0 Then
    　　DeleteFromXml = True
    　Else
    　　DeleteFromXml = False
    　　AddErr Err.Description
    　End If
    End Function

    ' 修改XML文件中的数据
    ' 需要首先设置好Id
    Public Function EditToXml(objXmlDoc)
    　Dim objPersonList, objOldPerson, objNewPerson, objNode

　ClearError

    　If objXmlDoc Is Nothing Then
    　　EditToXml = False
    　　AddErr "Dom对象为空值"
    　　Exit Function
    　End If

    　If CStr(m_intId) = "-1" Then
    　　EditToXml = False
    　　AddErr "未正确设置联系人对象的ID属性"
    　　Exit Function
    　End If

    　Set objPersonList = objXmlDoc.getElementsByTagName("Person")
    　If objPersonList.length - m_intId < 0 Then
    　　DeleteFromXml = False
    　　AddErr "未找到相应的联系人"
    　　Set objPersonList = Nothing
    　　Exit Function
    　End If

    　Set objOldPerson = objPersonList(m_intId-1) ' 要修改的旧节点

    　Set objNewPerson = objXmlDoc.createElement("Person") ' 用来替换旧节点的新节点
    　Set objNode = objXmlDoc.createElement("Name")
    　objNode.Text = m_strName
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Nick")
    　objNode.Text = m_strNick
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Mobile")
    　objNode.Text = m_strMobile
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Tel")
    　objNode.Text = m_strTel
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Email")
    　objNode.Text = m_strEmail
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("QQ")
    　objNode.Text = m_strQQ
    　objNewPerson.appendChild objNode

    　Set objNode = objXmlDoc.createElement("Company")
    　objNode.Text = m_strCompany
    　objNewPerson.appendChild objNode

    　On Error Resume Next
    　' 进行替换
    　Set objNode = objXmlDoc.documentElement.replaceChild(objNewPerson, objOldPerson)
    　If objNode Is Nothing Then
    　    EditToXml = False
    　    AddErr "修改联系人失败"
    　    Set objOldPerosn = Nothing
    　    Set objNewPerson = Nothing
    　    Set objPersonList = Nothing
    　    Exit Function
      Else
    　    objXmlDoc.save Server.MapPath(C_XMLFILE)
      End If

      Set objOldPerson = Nothing
      Set objNewPerson = Nothing
       Set objPersonList = Nothing

      If Err.Number = 0 Then
    　    EditToXml = True
      Else
    　     EditToXml = False
    　    AddErr Err.Description
      End If
    End Function
End Class