xml.asp

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

<%
'--------------------------------------------------------------------
' xml.asp - XML functions and definitions
'
' Copyright (c) 2006 - 2008 MOEx Group.
'
'
' last update: 2008/06/16
'
'--------------------------------------------------------------------

'--- Timeout constant for IServerXMLHTTPRequest2.setTimeouts ---
Public Const xmlDNSTimeout = 10000      '解析 DNS 的超时时间，单位：毫秒
Public Const xmlCONTimeout = 10000      '建立连接的超时时间，单位：毫秒
Public Const xmlSNDTimeout = 30000      '发送数据的超时时间，单位：毫秒
Public Const xmlRCVTimeout = 30000      '接收数据的超时时间，单位：毫秒

'--------------------------------------------------------------------
' XMLHttpRequest    - 创建MSXML2.ServerXMLHTTP.x对象
'                   - 返回类型：IServerXMLHTTPRequest2
'--------------------------------------------------------------------
Public Function XMLHttpRequest()
    On Error Resume Next
    Dim arr, ptr
    arr = Array _
    ( _
        "MSXML2.ServerXMLHTTP.6.0", _
        "MSXML2.ServerXMLHTTP.5.0", _
        "MSXML2.ServerXMLHTTP.4.0", _
        "MSXML2.ServerXMLHTTP.3.0", _
        "MSXML2.ServerXMLHTTP" _
    )
    For Each ptr In arr
        Set XMLHttpRequest = Server.CreateObject(ptr)
        If Err.Number Then
            Err.Clear
        Else
            XMLHttpRequest.setTimeouts xmlDNSTimeout, xmlCONTimeout, xmlSNDTimeout, xmlRCVTimeout
            Exit For
        End If
    Next
End Function

'--------------------------------------------------------------------
' GetRemoteBody     - 获取远程URL数据
'                   - 返回类型：Byte() Or Empty
'                   - arguments[0] = URL地址(type: String)
'--------------------------------------------------------------------
Public Function GetRemoteBody(ByVal strURL)
    Dim xmlHttp
    Set xmlHttp = Server.CreateObject(PROGID_XMLHTTP)
    xmlHttp.setTimeouts xmlDNSTimeout, xmlCONTimeout, xmlSNDTimeout, xmlRCVTimeout
    xmlHttp.open "GET", strURL, False
    xmlHttp.setRequestHeader "USER-AGENT", "MOExplorer/1.0"
    xmlHttp.send Null
    If xmlHttp.status = 200 Then
        GetRemoteBody = xmlHttp.responseBody
    End If
    Set xmlHttp = Nothing
End Function

'--------------------------------------------------------------------
' GetRemoteText     - 获取远程URL数据
'                   - 返回类型：String Or Empty
'                   - arguments[0] = URL地址(type: String)
'                   - arguments[1] = 指定字符集(type: String)
'--------------------------------------------------------------------
Public Function GetRemoteText(ByVal strURL, ByVal strCharset)
    Dim ret
    ret = GetRemoteBody(strURL)
    If VarType(ret) = (vbByte Or vbArray) Then
        GetRemoteText = BytesToString(ret, strCharset)
    End If
End Function

'--------------------------------------------------------------------
' GetResponseBody   - 发送数据至远程URL，并返回WEB服务器应答
'                   - 返回类型：Byte() Or Empty
'                   - arguments[0] = URL地址(type: String)
'                   - arguments[1] = 数据包(type: Object Or Byte() Or String)
'                   - arguments[2] = 数据包长度(type: Long)
'--------------------------------------------------------------------
Public Function GetResponseBody(ByVal strURL, vtData, ByVal lngSize)
    Dim xmlHttp
    Set xmlHttp = Server.CreateObject(PROGID_XMLHTTP)
    xmlHttp.setTimeouts xmlDNSTimeout, xmlCONTimeout, xmlSNDTimeout, xmlRCVTimeout
    xmlHttp.Open "POST", strURL, False
    xmlHttp.setRequestHeader "USER-AGENT", "MOExplorer/1.0"
    If TypeName(vtData) = "DOMDocument" Then
        xmlHttp.SetRequestHeader "Content-Type", "text/xml"
    Else
        xmlHttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    End If
    xmlHttp.SetRequestHeader "Content-Length", lngSize
    xmlHttp.Send vtData
    GetResponseBody = xmlHttp.responseBody
    Set xmlHttp = Nothing
End Function

'--------------------------------------------------------------------
' GetResponseText   - 发送数据至远程URL，并返回WEB服务器应答
'                   - 返回类型：String Or Empty
'                   - arguments[0] = URL地址(type: String)
'                   - arguments[1] = 数据包(type: Object Or Byte() Or String)
'                   - arguments[2] = 数据包长度(type: Long)
'                   - arguments[3] = 指定字符集(type: String)
'--------------------------------------------------------------------
Public Function GetResponseText(ByVal strURL, vtData, ByVal lngSize, ByVal strCharset)
    Dim ret
    ret = GetResponseBody(strURL, vtData, lngSize)
    If VarType(ret) = (vbByte Or vbArray) Then
        GetResponseText = BytesToString(ret, strCharset)
    End If
End Function

'--------------------------------------------------------------------
' XPathString       - 转换字符串为XPath可以使用的字符串
'                   - 返回类型：String
'                   - arguments[0] = 字符串(type: String)
'--------------------------------------------------------------------
Public Function XPathString(ByVal strData)
    Dim ret
    ret = strData
    ret = Replace(ret, "\", "\\")
    ret = Replace(ret, Chr(8), "\b")
    ret = Replace(ret, Chr(9), "\t")
    ret = Replace(ret, Chr(10), "\n")
    ret = Replace(ret, Chr(12), "\f")
    ret = Replace(ret, Chr(13), "\r")
    ret = Replace(ret, Chr(34), "\""")
    ret = Replace(ret, Chr(39), "\'")
    XPathString = ret
End Function

'--------------------------------------------------------------------
' XMLTransformToBinary  - 用XSL解析XML文档为字节数组
'                   - 返回类型：Byte()
'                   - arguments[0] = XML文档对象(type: IXMLDOMElement) 
'                   - arguments[1] = XSL文档对象(type: IXMLDOMElement)
'--------------------------------------------------------------------
Public Function XMLTransformToBinary(xmlDoc, xslDoc)
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    xmlDoc.transformNodeToObject xslDoc, objTemp
    objTemp.Position = 0
    XMLTransformToBinary = objTemp.Read(adReadAll)
    objTemp.Close
    Set objTemp = Nothing
End Function

'--------------------------------------------------------------------
' XMLTransformToString  - 用XSL解析XML文档为字符串
'                   - 返回类型：String
'                   - arguments[0] = XML文档对象(type: IXMLDOMElement) 
'                   - arguments[1] = XSL文档对象(type: IXMLDOMElement)
'                   - arguments[2] = 指定解析的字符集(type: String)
'--------------------------------------------------------------------
Public Function XMLTransformToString(xmlDoc, xslDoc, ByVal strCharset)
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    xmlDoc.transformNodeToObject xslDoc, objTemp
    objTemp.Position = 0
    objTemp.Type = adTypeText
    objTemp.Charset = strCharset
    XMLTransformToString = objTemp.ReadText(adReadAll)
    objTemp.Close
    Set objTemp = Nothing
End Function

Public Function XMLSaveToFile(xmlDoc, ByVal strPath)
    On Error Resume Next
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Mode = adModeShareExclusive
    objTemp.Open
    xmlDoc.save objTemp
    If Err.Number Then Err.Clear
    objTemp.SaveToFile strPath, adSaveCreateOverWrite
    objTemp.Close
    Set objTemp = Nothing
    XMLSaveToFile = CBool(Err.Number = 0)
End Function

Public Sub XMLSetNamespaces(xmlDoc)
    Dim xmlRoot, xmlAttr
    Dim arr, i
    Set xmlRoot = xmlDoc.documentElement
    ReDim arr(xmlRoot.attributes.length - 1)
    i = 0
    For Each xmlAttr In xmlRoot.attributes
        If Left(xmlAttr.name, 5) = "xmlns" Then
            arr(i) = str_format("$0=$1$2$1", Array(xmlAttr.name, Chr(34), xmlAttr.value))
            i = i + 1
        End If
    Next
    ReDim Preserve arr(i - 1)
    Set xmlRoot = Nothing
    If UBound(arr) < 0 Then Exit Sub
    xmlDoc.setProperty "SelectionNamespaces", Join(arr, " ")
End Sub

Public Function XMLQuery(xmlNode, ByVal strXSQL)
    Set XMLQuery = xmlNode.selectSingleNode(strXSQL)
End Function

Public Function XMLQueries(xmlNode, ByVal strXSQL)
    Set XMLQueries = xmlNode.selectNodes(strXSQL)
End Function

Public Function XMLAttr(xmlNode, ByVal strAttr)
    XMLAttr = atos(xmlNode.getAttribute(strAttr))
End Function

Public Function XMLLoadFile(ByVal strPath)
    Set XMLLoadFile = xml.cloneNode(True)
    XMLLoadFile.async = False
    If Not XMLLoadFile.load(strPath) Then
        Err.Raise vbObjectError + 1, "XMLLoadFile", "Invalid xml file(" & strPath & "): " & XMLLoadFile.parseError.reason
    End If
    XMLSetNamespaces XMLLoadFile
End Function

Public Function XMLLoadString(ByVal strData)
    Set XMLLoadString = xml.cloneNode(True)
    XMLLoadString.async = False
    If Not XMLLoadString.loadXML(strData) Then
        Err.Raise vbObjectError + 1, "XMLLoadString", "Invalid xml string(" & strData & "): " & XMLLoadString.parseError.reason
    End If
    XMLSetNamespaces XMLLoadString
End Function

Public Function XMLLoadURL(ByVal strURL)
    Set XMLLoadURL = xml.cloneNode(True)
    XMLLoadURL.async = False
    XMLLoadURL.setProperty "ServerHTTPRequest", True
    If Not XMLLoadURL.load(strURL) Then
        Err.Raise vbObjectError + 1, "XMLLoadURL", "Invalid xml url(" & strURL & "): " & XMLLoadURL.parseError.reason
    End If
    XMLSetNamespaces XMLLoadURL
End Function

Public Function XMLToString(xmlDoc, ByVal strCharset)
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    xmlDoc.save objTemp
    objTemp.Position = 0
    objTemp.Type = adTypeText
    objTemp.Charset = strCharset
    XMLToString = objTemp.ReadText(adReadAll)
    objTemp.Close
    Set objTemp = Nothing
End Function

Public Function XMLToBinary(xmlDoc)
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    xmlDoc.save objTemp
    objTemp.Position = 0
    XMLToBinary = objTemp.Read(adReadAll)
    objTemp.Close
    Set objTemp = Nothing
End Function
%>