xmldb

WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品

Private xmlDoc, xmlRoot
Private xmlTrans
Private xmlFields, xmlRows
Private xmlProperties, xmlRow
Private xmlList
Private strTableName
Private strXDBPath
Private blnModify
Private intCursor
Private blnFilter

Private Sub Class_Initialize()
    Set xmlDoc = xml.cloneNode(True)
    Set xmlRoot = Nothing
    Set xmlFields = Nothing
    Set xmlRows = Nothing
    Set xmlProperties = Nothing
    Set xmlRow = Nothing
    Set xmlList = Nothing
    intCursor = 0
    blnModify = False
    blnFilter = False
End Sub

Private Sub Class_Terminate()
    If blnModify Then
        XMLSaveToFile xmlDoc, strXDBPath
    End If
    Set xmlList = Nothing
    Set xmlRow = Nothing
    Set xmlProperties = Nothing
    Set xmlRows = Nothing
    Set xmlFields = Nothing
    Set xmlRoot = Nothing
    Set xmlTrans = Nothing
    Set xmlDoc = Nothing
End Sub

Public Function LastModify(ByVal strName)
    LadModify = GetFileModify(GetMapPath("database/" & strName & ".xdb"))
End Function

Public Function Expires(ByVal strName)
    Dim strPath
    strPath = GetMapPath("database/" & strName & ".xdb")
    If fso.FileExists(strPath) Then
        Expires = DateDiff("n", GetFileModify(strPath), Now())
    Else
        Expires = -1
    End If
End Function

Public Function Drop(ByVal strName)
    Dim strPath
    strPath = GetMapPath("database/" & strName & ".xdb")
    If fso.FileExists(strPath) Then
        fso.DeleteFile strPath
        Drop = True
    Else
        Drop = False
    End If
End Function

Public Function Execute(ByVal strName)
    strTableName = strName
    strXDBPath = GetMapPath("database/" & strName & ".xdb")
    xmlDoc.async = False
    xmlDoc.setProperty "SelectionLanguage", "XPath"
    Execute = xmlDoc.Load(strXDBPath)
    If Not Execute Then
        xmlDoc.appendChild xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
        Set xmlRoot = xmlDoc.createElement("xml")
        xmlDoc.appendChild xmlRoot
        xmlRoot.appendChild xmlDoc.createElement("fields")
        xmlRoot.appendChild xmlDoc.createElement("rows")
        xmlRoot.appendChild xmlDoc.createElement("properties")
        blnModify = True
    Else
        Set xmlRoot = xmlDoc.documentElement
    End If
    Set xmlFields = xmlRoot.selectSingleNode("fields")
    Set xmlRows = xmlRoot.selectSingleNode("rows")
    Set xmlProperties = xmlRoot.selectSingleNode("properties")
    Set xmlList = xmlRows.childNodes
End Function

Public Sub Append(ByVal strName, ByVal intType, ByVal intSize)
    Dim xmlNode
    Set xmlNode = xmlFields.selectSingleNode("attribute[@name='" & strName & "']")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("attribute")
        xmlNode.setAttribute "name", strName
        xmlNode.setAttribute "type", intType
        xmlNode.setAttribute "size", intSize
        xmlFields.appendChild xmlNode
    Else
        xmlNode.setAttribute "type", intType
        xmlNode.setAttribute "size", intSize
    End If
    Set xmlNode = Nothing
    blnModify = True
End Sub

Private Function GetField(ByVal strName)
    Set GetField = xmlFields.selectSingleNode("attribute[@name='" & strName & "']")
End Function

Public Sub AddNew()
    Set xmlRow = Nothing
    Set xmlRow = xmlDoc.createElement("row")
End Sub

Public Default Property Get Item(ByVal strName)
    Dim xmlField
    Dim xmlNode
    Set xmlField = GetField(strName)
    If xmlField Is Nothing Then
        Err.Raise vbObjectError + 1, "ImplXMLDB.Item", "Missing Field: " & strName
    End If
    Set xmlNode = xmlList(intCursor)
    Select Case atol(xmlField.getAttribute("type"))
    Case adInteger
        Item = atol(xmlNode.getAttribute(strName))
    Case adDouble
        Item = atof(xmlNode.getAttribute(strName))
    Case Else
        Item = atos(xmlNode.getAttribute(strName))
    End Select
    Set xmlNode = Nothing
    Set xmlField = Nothing
End Property

Public Property Let Item(ByVal strName, vtIn)
    Dim xmlField
    Dim xmlNode
    Set xmlField = GetField(strName)
    If xmlField Is Nothing Then
        Err.Raise vbObjectError + 1, "ImplXMLDB.Item", "Missing Field: " & strName
    End If
    If xmlRow Is Nothing Then
        Set xmlNode = xmlList(intCursor)
        Select Case atol(xmlField.getAttribute("type"))
        Case adInteger
            xmlNode.setAttribute strName, atol(vtIn)
        Case adDouble
            xmlNode.setAttribute strName, atof(vtIn)
        Case Else
            xmlNode.setAttribute strName, atos(vtIn)
        End Select
        Set xmlNode = Nothing
    Else
        Select Case atol(xmlField.getAttribute("type"))
        Case adInteger
            xmlRow.setAttribute strName, atol(vtIn)
        Case adDouble
            xmlRow.setAttribute strName, atof(vtIn)
        Case Else
            xmlRow.setAttribute strName, atos(vtIn)
        End Select
    End If
    Set xmlField = Nothing
End Property

Public Property Get Properties(ByVal strName)
    Dim xmlNode
    Set xmlNode = xmlProperties.selectSingleNode("property[@name='" & strName & "']")
    If Not xmlNode Is Nothing Then
        Properties = xmlNode.getAttribute("value")
    End If
    Set xmlNode = Nothing
End Property

Public Property Let Properties(ByVal strName, vtIn)
    Dim xmlNode
    Set xmlNode = xmlProperties.selectSingleNode("property[@name='" & strName & "']")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("property")
        xmlProperties.appendChild xmlNode
    End If
    xmlNode.setAttribute "name", strName
    xmlNode.setAttribute "value", vtIn
    Set xmlNode = Nothing
    blnModify = True
End Property

Public Property Get Config(ByVal strName)
    Dim xmlNode
    Set xmlNode = xmlRoot.selectSingleNode(strName)
    If Not xmlNode Is Nothing Then
        Config = xmlNode.Text
    End If
    Set xmlNode = Nothing
End Property

Public Property Let Config(ByVal strName, vtIn)
    Dim xmlNode
    Set xmlNode = xmlRoot.selectSingleNode(strName)
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement(strName)
        xmlRoot.appendChild xmlNode
    End If
    xmlNode.Text = vtIn
    Set xmlNode = Nothing
    blnModify = True
End Property

Public Sub Update()
    If Not xmlRow Is Nothing Then
        If Not IsEmpty(Me.Properties("Sequence")) Then
            Dim lngSeq
            lngSeq = atol(Me.Config("Sequence"))
            xmlRow.setAttribute Me.Properties("Sequence"), lngSeq
            Me.Config("Sequence") = lngSeq + 1
        End If
        xmlRows.appendChild xmlRow
        Set xmlRow = Nothing
    End If
    blnModify = True
End Sub

Public Property Get RecordCount()
    RecordCount = xmlList.Length
End Property

Public Property Get EOF()
    Dim intCount
    intCount = xmlList.Length
    If intCount = 0 Then
        EOF = True
    ElseIf intCursor = intCount Then
        EOF = True
    Else
        EOF = False
    End If
End Property

Public Sub MoveNext()
    intCursor = intCursor + 1
End Sub

Public Sub MoveFirst()
    intCursor = 0
End Sub

Public Sub MoveLast()
    intCursor = xmlList.Length - 1
End Sub

Public Sub Move(ByVal i)
    intCursor = i
End Sub

Public Property Let Filter(ByVal strXQL)
    Set xmlList = xmlRows.selectNodes("row[" & strXQL & "]")
    intCursor = 0
    blnFilter = True
End Property

Public Property Let Sort(ByVal strData)
    Dim objXML
    Dim objXSL
    Dim xmlNode
    Dim strName
    Dim arr
    arr = Split(strData, " ")
    strName = "WAPmo.XDB.Translate"

    Set objXML = xml.cloneNode(True)
    objXML.appendChild objXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
    objXML.appendChild objXML.createElement("rows")
    For Each xmlNode In xmlList
        objXML.documentElement.appendChild xmlNode.cloneNode(True)
    Next

    If IsEmpty(GetCache(strName)) Then
        Set objXSL = xml.cloneNode(True)
        objXSL.async = False
        objXSL.loadXML "<?xml version=""1.0"" encoding=""utf-8""?><xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform""><xsl:template match=""rows""><rows><xsl:for-each select=""row""><xsl:sort select=""SeqId"" order=""ascending""/><row><xsl:for-each select=""@*""><xsl:attribute name=""{name()}""><xsl:value-of select=""."" /></xsl:attribute></xsl:for-each></row></xsl:for-each></rows></xsl:template></xsl:stylesheet>"
        SetCache strName, objXSL
    Else
        Set objXSL = GetCache(strName)
    End If
    objXSL.documentElement.selectSingleNode("//xsl:sort/@select").Text = arr(0)
    objXSL.documentElement.selectSingleNode("//xsl:sort/@order").Text = arr(1)

    Set xmlTrans = Nothing
    Set xmlTrans = xml.cloneNode(True)
    xmlTrans.async = False
    xmlTrans.loadXML objXML.transformNode(objXSL)

    Set objXSL = Nothing
    Set objXML = Nothing

    Set xmlList = xmlTrans.documentElement.childNodes
End Property

Public Sub Delete(ByVal blnAffact)
    Dim xmlNode
    Dim i
    If Not blnAffact Then
        Set xmlNode = xmlList(intCursor)
        xmlNode.parentNode.removeChild xmlNode
        Set xmlNode = Nothing
    Else
        For i = 0 To xmlList.Length - 1
            Set xmlNode = xmlList(IIf(blnFilter, i, 0))
            xmlNode.parentNode.removeChild xmlNode
            Set xmlNode = Nothing
        Next
        intCursor = 0
    End If
    blnModify = True
End Sub