xmlparser.asp

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

<%
Class ImplMocomWAPmoXMLParser
Private xmlDoc
Private xmlRoot
Private xmlHead
Private xmlBody
Private xmlPart
Private strAlign
Private xmlForm
Private xmlSelect
Private xmlGroup
Private strDocType
Private strContentType

Private Sub Class_Initialize()
    Set xmlDoc = xml.cloneNode(True)
    xmlDoc.appendChild xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""GBK""")
    xmlDoc.appendChild xmlDoc.createElement("xml")
    Set xmlRoot = xmlDoc.documentElement
    Set xmlHead = xmlDoc.createElement("head")
    Set xmlBody = xmlDoc.createElement("body")
    Set xmlPart = Nothing
    Set xmlForm = Nothing
    Set xmlSelect = Nothing
    Set xmlGroup = Nothing
    xmlRoot.appendChild xmlHead
    xmlRoot.appendChild xmlBody
    strDocType = "wml"
    strContentType = "text/vnd.wap.wml"
    strAlign = "left"
End Sub

Private Sub Class_Terminate()
    Set xmlGroup = Nothing
    Set xmlSelect = Nothing
    Set xmlForm = Nothing
    Set xmlPart = Nothing
    Set xmlHead = Nothing
    Set xmlBody = Nothing
    Set xmlRoot = Nothing
    Set xmlDoc = Nothing
End Sub

Public Property Get Core()
    Set Core = xmlDoc
End Property

Public Property Get Head()
    Set Head = xmlHead
End Property

Public Property Get Body()
    Set Body = xmlBody
End Property

Public Property Get Form()
    Set Form = xmlForm
End Property

Public Property Let DocType(ByVal strIn)
    Dim strAccept
    strDocType = LCase(strIn)
    strAccept = MyIO.Env("HTTP_ACCEPT")
    Select Case strDocType
    Case "xhtml"
        If InStr(strAccept, "application/vnd.wap.xhtml+xml") > 0 Then
            strContentType = "application/vnd.wap.xhtml+xml"
        ElseIf InStr(strAccept, "application/xhtml+xml") > 0 Then
            strContentType = "application/xhtml+xml"
        Else
            strContentType = "application/vnd.wap.xhtml+xml"
        End If
    Case "wml"
        strContentType = "text/vnd.wap.wml"
    Case "html"
        strContentType = "text/html"
    End Select
End Property

Public Property Let Title(ByVal strIn)
    Dim xmlNode
    Set xmlNode = xmlHead.selectSingleNode("title")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("title")
        xmlHead.appendChild xmlNode
    End If
    xmlNode.Text = strIn
    Set xmlNode = Nothing
End Property

Public Property Let Meta(ByVal strName, ByVal strValue, ByVal strContent)
    Dim xmlNode
    Set xmlNode = xmlHead.selectSingleNode("meta[@" & strName & "='" & strValue & "']")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("meta")
        xmlNode.setAttribute strName, strValue
        xmlHead.appendChild xmlNode
    End If
    xmlNode.setAttribute "content", strContent
    Set xmlNode = Nothing
End Property

Public Sub Redirect(ByVal strURL, ByVal lngSec)
    Dim xmlNode
    Set xmlNode = xmlHead.selectSingleNode("redirect")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("redirect")
        xmlHead.appendChild xmlNode
    End If
    xmlNode.setAttribute "url", strURL
    xmlNode.setAttribute "timer", lngSec
    Set xmlNode = Nothing
End Sub

Public Property Let Style(ByVal strName, ByVal strValue)
    Dim xmlNode
    Set xmlNode = xmlHead.selectSingleNode("style[@name='" & strName & "']")
    If xmlNode Is Nothing Then
        Set xmlNode = xmlDoc.createElement("style")
        xmlNode.setAttribute "name", strName
        xmlNode.setAttribute "value", strValue
        xmlHead.appendChild xmlNode
    Else
        xmlNode.setAttribute "value", xmlNode.getAttribute("value") & ";" & strValue
    End If
    Set xmlNode = Nothing
End Property

Public Property Let Align(ByVal strIn)
    If strAlign <> LCase(strIn) Then
        strAlign = LCase(strIn)
        If Not xmlPart Is Nothing Then
            Set xmlPart = Nothing
        End If
        Set xmlPart = xmlDoc.createElement("p")
        xmlPart.setAttribute "align", strAlign
        xmlBody.appendChild xmlPart
    ElseIf xmlPart Is Nothing Then
        strAlign = LCase(strIn)
        Set xmlPart = xmlDoc.createElement("p")
        xmlPart.setAttribute "align", strAlign
        xmlBody.appendChild xmlPart
    End If
End Property

Private Sub Copy(xmlNode, ByVal strIn)
    If strIn = "" Then Exit Sub
    Dim arr
    Dim k
    arr = Split(Replace(strIn, Chr(13), ""), Chr(10))
    xmlNode.appendChild xmlDoc.createTextNode(arr(0))
    For k = 1 To UBound(arr)
        xmlNode.appendChild xmlDoc.createElement("br")
        xmlNode.appendChild xmlDoc.createTextNode(arr(k))
    Next
End Sub

Public Sub Printf(vtIn)
    If xmlPart Is Nothing Then Align = "left"
    If VarType(vtIn) = vbObject Then
        xmlPart.appendChild vtIn
    Else
        Copy xmlPart, vtIn
    End If
End Sub

Public Sub Println(vtIn)
    Call Printf(vtIn)
    Call Printf(xmlDoc.createElement("br"))
End Sub

Public Function CreateA(ByVal strHref, vtTitle, vtPrefix, vtSuffix)
    Set CreateA = xmlDoc.createElement("a")
    CreateA.setAttribute "href", strHref
    CreateA.setAttribute "title", "确定"
    If VarType(vtPrefix) = vbObject Then
        CreateA.appendChild vtPrefix
    ElseIf vtPrefix <> "" Then
        CreateA.appendChild CreateImg(vtPrefix, "装载中……", -1, -1)
    End If
    If VarType(vtTitle) = vbObject Then
        CreateA.appendChild vtTitle
    Else
        Copy CreateA, vtTitle
    End If
    If VarType(vtSuffix) = vbObject Then
        CreateA.appendChild vtSuffix
    ElseIf vtSuffix <> "" Then
        CreateA.appendChild CreateImg(vtSuffix, "装载中……", -1, -1)
    End If
End Function

Public Function CreateImg(ByVal strSrc, ByVal strAlt, ByVal intWidth, ByVal intHeight)
    Set CreateImg = xmlDoc.createElement("img")
    CreateImg.setAttribute "src", strSrc
    CreateImg.setAttribute "alt", strAlt
    If intWidth > -1 Then
        CreateImg.setAttribute "width", intWidth
    End If
    If intHeight > -1 Then
        CreateImg.setAttribute "height", intHeight
    End If
End Function

Public Function CreateX(ByVal strFmt, vtIn)
    Dim intPos
    intPos = InStr(strFmt, "|")
    If intPos = 0 Then
        Set CreateX = xmlDoc.createElement(strFmt)
        If VarType(vtIn) = vbObject Then
            CreateX.appendChild vtIn
        Else
            Copy CreateX, vtIn
        End If
    Else
        Set CreateX = xmlDoc.createElement(Left(strFmt, intPos - 1))
        CreateX.appendChild CreateX(Mid(strFmt, intPos + 1), vtIn)
    End If
End Function

Public Function CreateB(vtIn)
    Set CreateB = CreateX("b", vtIn)
End Function

Public Function CreateI(vtIn)
    Set CreateI = CreateX("i", vtIn)
End Function

Public Function CreateU(vtIn)
    Set CreateU = CreateX("u", vtIn)
End Function

Private Function Encode(ByVal strIn)
    Dim ret
    ret = strIn
    ret = Replace(ret, vbCrLf, "<br/>")
    ret = Replace(ret, "&", "&amp;")
    Encode = ret
End Function

Public Function CreateT(vtIn)
    Set CreateT = xmlDoc.createElement("text")
    CreateT.Text = Encode(vtIn)
End Function

Public Sub SetF(ByVal strAction, ByVal strMethod, ByVal strEnctype, ByVal blnCrLf)
    If Not xmlForm Is Nothing Then Set xmlForm = Nothing
    Set xmlForm = xmlDoc.createElement("form")
    xmlForm.setAttribute "action", strAction
    xmlForm.setAttribute "method", LCase(strMethod)
    If strEnctype = "" Then
        xmlForm.setAttribute "enctype", "application/x-www-form-urlencoded"
    Else
        xmlForm.setAttribute "enctype", strEnctype
    End If
    If blnCrLf Then
        Println xmlForm
    Else
        Printf xmlForm
    End If
End Sub

Public Sub SetN(ByVal strName, ByVal strType, vtValue, ByVal strPrefix, ByVal strSuffix, ByVal blnCrLf, ByVal intLength, ByVal intSize, ByVal strFormat)
    Dim xmlNode
    Set xmlNode = xmlForm.appendChild(xmlDoc.createElement("input"))
    xmlNode.setAttribute "name", strName
    xmlNode.setAttribute "type", LCase(strType)
    xmlNode.setAttribute "value", vtValue
    xmlNode.setAttribute "prefix", strPrefix
    xmlNode.setAttribute "suffix", strSuffix
    If atoi(intLength) > 0 Then
        xmlNode.setAttribute "maxlength", intLength
    End If
    If atoi(intSize) > 0 Then
        xmlNode.setAttribute "size", intSize
    End If
    If strFormat <> "" Then
        xmlNode.setAttribute "format", strFormat
    End If
    Set xmlNode = Nothing
    If blnCrLf Then
        xmlForm.appendChild xmlDoc.createElement("br")
    End If
End Sub

Public Sub SetS(ByVal strName, vtValue, ByVal strPrefix, ByVal strSuffix, ByVal blnCrLf)
    If Not xmlSelect Is Nothing Then
        Set xmlGroup = Nothing
        Set xmlSelect = Nothing
    End If
    Set xmlSelect = xmlDoc.createElement("select")
    xmlSelect.setAttribute "name", strName
    xmlSelect.setAttribute "value", vtValue
    xmlSelect.setAttribute "prefix", strPrefix
    xmlSelect.setAttribute "suffix", strSuffix
    xmlForm.appendChild xmlSelect
    If blnCrLf Then
        xmlForm.appendChild xmlDoc.createElement("br")
    End If
End Sub

Public Sub SetG(ByVal strTitle)
    If Not xmlGroup Is Nothing Then Set xmlGroup = Nothing
    Set xmlGroup = xmlDoc.createElement("optgroup")
    xmlGroup.setAttribute "title", strTitle
    xmlSelect.appendChild xmlGroup
End Sub

Public Sub SetO(vtValue, vtText)
    Dim xmlNode
    Set xmlNode = xmlDoc.createElement("option")
    xmlNode.setAttribute "value", vtValue
    xmlNode.Text = vtText
    If xmlGroup Is Nothing Then
        xmlSelect.appendChild xmlNode
    Else
        xmlGroup.appendChild xmlNode
    End If
    Set xmlNode = Nothing
End Sub

Public Function CreateC(vtIn)
    Set CreateC = xmlDoc.createComment(vtIn)
End Function

Public Function CreateAnchor(ByVal strURL, ByVal strTitle)
    Dim xmlGO
    Set CreateAnchor = xmlDoc.createElement("anchor")
    CreateAnchor.setAttribute "title", strTitle
    CreateAnchor.appendChild xmlDoc.createTextNode(strTitle)
    Set xmlGO = CreateAnchor.appendChild(xmlDoc.createElement("go"))
    xmlGO.setAttribute "href", strURL
    xmlGO.setAttribute "sendreferer", "true"
    Set xmlGO = Nothing
End Function

Public Function Transform(vtDest)
    Response.ContentType = strContentType
    Response.Charset = "utf-8"
    Transform = TransformToObject(strDocType, vtDest)
End Function

Public Function TransformToObject(ByVal strType, vtDest)
    Dim xslDoc, objTemp
    Set xslDoc = GetTransfer(strType)
    If VarType(vtDest) = vbObject Then
        xmlDoc.transformNodeToObject xslDoc, vtDest
    Else
        Set objTemp = Server.CreateObject("ADODB.Stream")
        objTemp.Type = adTypeBinary
        objTemp.Mode = adModeShareExclusive
        objTemp.Open
        xmlDoc.transformNodeToObject xslDoc, objTemp
        objTemp.SaveToFile vtDest, adSaveCreateOverWrite
        objTemp.Close
        Set objTemp = Nothing
    End If
    Set xslDoc = Nothing
End Function

Private Function GetTransfer(ByVal strType)
    Dim xslDoc
    Dim strName
    strName = "WAPmo.Translater." & strType
    If IsEmpty(GetCache(strName)) Then
        Set xslDoc = XMLLoadFile(GetMapPath("config/" & strType & ".xsl"))
        SetCache strName, xslDoc
    Else
        Set xslDoc = GetCache(strName).cloneNode(True)
    End If
    Set GetTransfer = xslDoc
    Set xslDoc = Nothing
End Function

Public Function newInstance()
    Set newInstance = New ImplMocomWAPmoXMLParser
End Function
End Class
%>