程式師世界 >> 編程語言 >> 網頁編程 >> ASP編程 >> ASP技巧 >> asp處理xml數據的發送、接收類

asp處理xml數據的發送、接收類

編輯：ASP技巧

本ASP類可以用來處理XML包的發送與接收。可用於各種異構系統之間API接口間通訊，以及處理Web Service的調用與接收。

屬性：

URL : 發送XML的接收地址

String
只寫

Message : 系統錯誤信息
String
只讀

XmlNode:獲取發送包XML中節點的值
String
只讀
參數：Str:節點名稱

GetXmlData: 獲取返回XML數據對象
XMLDom
只讀

方法：

LoadXmlFromFile : 從外部xml文件填充XMLDoc對象
參數 Path:XML路徑
Void

LoadXmlFromString : 用字符串填充XMLDoc對象
參數 Str:XML字符串
Void

NodeValue 設置node的參數

參數

NodeName 節點名

NodeText 值

NodeType 保存類型 [text=0,cdata=1]

blnEncode 是否編碼 [true,false]
Void

SendHttpData : 發送XML包

PRintSendXmlData : 打印發送請求XML數據

PrintGetXmlData : 打印返回XML數據

SaveSendXmlDataToFile : 保存發送請求xml數據到文件，文件名為sendXML_日期.txt

SaveGetXmlDataToFile : 保存返回XML數據到文件，文件名為getXML_日期.txt

GetSingleNode : 獲取返回XML的節點信息
參數 Nodestring：節點名

AcceptHttpData : 接收XML包，錯誤信息通過Message對象獲取

AcceptSingleNode: 返回接收XML包節點信息
參數 Nodestring：節點名

PrintAcceptXmlData : 打印接收端接收到的XML數據

SaveAcceptXmlDataToFile : 保存接收的XML包數據到文件，文件名為acceptXML_日期.txt

SaveDebugStringToFile : 保存調試數據到文件，文件名為debugnote_日期.txt
參數 Debugstr：調試信息

代碼:

XMLcls.ASP

Rem 處理XML數據的發送、接收類
'--------------------------------------------------
'轉載的時候請保留版權信息
'作者:walkman
'公司:步步為贏科技有限責任公司
'網址:http://www.shouji138.com
'版本:ver1.0
'--------------------------------------------------

Class XMLClass

Rem 變量定義
Private XmlDoc,XMLhttp
Private MessageCode,SysKey,XMLPath
Private m_GetXMLDoc,m_url
Private m_XMLDocAccept

Rem 初始化
Private Sub Class_Initialize()
   On Error Resume Next
   MessageCode = ""
   XMLPath = ""
   Set XmlDoc = Server.CreateObject("msXML2.FreeThreadedDOMDocument.3.0")
   XMLDoc.ASYNC = False
End Sub

Rem 銷毀對象
Private Sub Class_Terminate()
   If IsObject(XmlDoc) Then Set XMLDoc = Nothing
   If IsObject(m_XmlDocAccept) Then Set m_XMLDocAccept = Nothing
   If IsObject(m_GetXmlDoc) Then Set m_GetXMLDoc = Nothing
End Sub

'公共屬性定義開始--------------------------
Rem 錯誤信息
Public Property Get Message()
Message = MessageCode
End Property

Rem 發送XML的地址
Public Property Let URL(str)
m_url = str
End Property
'公共屬性定義結束--------------------------

'私有過程、方法開始--------------------------
Rem 加載XML
Private Sub LoadXMLData()
   If XMLPath <> "" Then
    If Not XmlDoc.Load(XMLPath) Then
     XmlDoc.LoadXml "<?XML version=""1.0"" encoding=""gb2312""?><root/>"
    End If
   Else
    XmlDoc.LoadXml "<?XML version=""1.0"" encoding=""gb2312""?><root/>"
   End If
End Sub

Rem 字符轉化
Private Function AnsiToUnicode(ByVal str)
   Dim i, j, c, i1, i2, u, fs, f, p
   AnsiToUnicode = ""
   p = ""
   For i = 1 To Len(str)
    c = Mid(str, i, 1)
    j = AscW(c)
    If j < 0 Then
     j = j + 65536
    End If
    If j >= 0 And j <= 128 Then
     If p = "c" Then
      AnsiToUnicode = " " & AnsiToUnicode
      p = "e"
     End If
     AnsiToUnicode = AnsiToUnicode & c
    Else
     If p = "e" Then
      AnsiToUnicode = AnsiToUnicode & " "
      p = "c"
     End If
     AnsiToUnicode = AnsiToUnicode & ("&#" & j & ";")
    End If
   Next
End Function

Rem 字符轉化
Private Function strAnsi2Unicode(asContents)
   Dim len1,i,varchar,varasc
   strAnsi2Unicode = ""
   len1=LenB(asContents)
   If len1=0 Then Exit Function
    For i=1 to len1
    varchar=MidB(asContents,i,1)
    varasc=AscB(varchar)
    If varasc > 127 Then
     If MidB(asContents,i+1,1)<>"" Then
      strAnsi2Unicode = strAnsi2Unicode & chr(ascw(midb(asContents,i+1,1) & varchar))
     End If
     i=i+1
    Else
     strAnsi2Unicode = strAnsi2Unicode & Chr(varasc)
    End If
   Next
End Function

Rem 往文件中追加字符
Private Sub WriteStringToFile(filename,str)
   On Error Resume Next
   Dim fs,ts
   Set fs= createobject("script_ing.filesystemobject")
   If Not IsObject(fs) Then Exit Sub
   Set ts=fs.OpenTextFile(Server.MapPath(filename),8,True)
   ts.writeline(str)
   ts.close
   Set ts=Nothing
   Set fs=Nothing
End Sub
'私有過程、方法結束--------------------------

'公共方法開始--------------------------

'''''''''''發送XML部分開始
Rem 從外部xml文件填充XMLDoc對象
Public Sub LoadXMLFromFile(path)
XMLPath = Server.MapPath(path)
LoadXMLData()
End Sub

Rem 用字符串填充XMLDoc對象
Public Sub LoadXMLFromString(str)
XmlDoc.LoadXML str
End Sub

Rem 設置node的參數如 NodeValue "appID",AppID,1,False
'--------------------------------------------------
'參數：
'NodeName 節點名
'NodeText 值
'NodeType 保存類型 [text=0,cdata=1]
'blnEncode 是否編碼 [true,false]
'--------------------------------------------------
Public Sub NodeValue(Byval NodeName,Byval NodeText,Byval NodeType ,Byval blnEncode)
   Dim ChildNode,CreateCDATASection
   NodeName = Lcase(NodeName)
   If XMLDoc.documentElement.selectSingleNode(NodeName) is nothing Then
    Set ChildNode = XmlDoc.documentElement.appendChild(XMLDoc.createNode(1,NodeName,""))
   Else
    Set ChildNode = XMLDoc.documentElement.selectSingleNode(NodeName)
   End If
   If blnEncode = True Then
    NodeText = AnsiToUnicode(NodeText)
   End If
   If NodeType = 1 Then
    ChildNode.Text = ""
    Set CreateCDATASection = XMLDoc.createCDATASection(Replace(NodeText,"]]>","]]>"))
    ChildNode.appendChild(createCDATASection)
   Else
    ChildNode.Text = NodeText
   End If
End Sub

'--------------------------------------------------
'獲取發送包XML中節點的值
'參數：
'Str 節點名
'--------------------------------------------------
Public Property Get XMLNode(Byval Str)
   If XMLDoc.documentElement.selectSingleNode(Str) is Nothing Then
    XMLNode = "Null"
   Else
    XmlNode = XMLDoc.documentElement.selectSingleNode(Str).text
   End If
End Property

'--------------------------------------------------
'獲取返回XML數據對象
'例：
'當GetXmlData不為NULL時，GetXmlData為XML對象
'--------------------------------------------------
Public Property Get GetXMLData()
Set GetXmlData = m_GetXMLDoc
End Property

'--------------------------------------------------
'發送XML包 http://www.devdao.com/
'--------------------------------------------------
Public Sub SendHttpData()
   Dim i,GetXMLDoc,LoadAppid
   Set Xmlhttp = Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
   Set GetXmlDoc = Server.CreateObject("msxml2.FreeThreadedDOMDocument.3.0") ' 返回XML包
    XMLHttp.Open "POST", m_url, false
    XmlHttp.SetRequestHeader "content-type", "text/XML"
    XmlHttp.Send XMLDoc
    'Response.Write strAnsi2Unicode(XMLhttp.responseBody)
    If GetXmlDoc.load(XmlHttp.responseXML) Then
     Set m_GetXmlDoc = GetXMLDoc
    Else
     MessageCode = "請求數據錯誤！"
     Exit Sub
    End If
   Set GetXMLDoc = Nothing
   Set XMLHttp = Nothing
End Sub

'--------------------------------------------------
'打印發送請求XML數據
'--------------------------------------------------
Public Sub PrintSendXMLData()
   Response.Clear
   Response.ContentType = "text/XML"
   Response.CharSet = "gb2312"
   Response.Expires = 0
   Response.Write "<?XML version=""1.0"" encoding=""gb2312""?>"&vbNewLine
   Response.Write XmlDoc.documentElement.XML
End Sub

'--------------------------------------------------
'打印返回XML數據
'--------------------------------------------------
Public Sub PrintGetXMLData()

   Response.Clear
   Response.ContentType = "text/XML"
   Response.CharSet = "gb2312"
   Response.Expires = 0
   If IsObject(m_GetXMLDoc) Then
    Response.Write "<?XML version=""1.0"" encoding=""gb2312""?>"&vbNewLine
    Response.Write m_GetXmlDoc.documentElement.XML
   Else
    Response.Write "<?XML version=""1.0"" encoding=""gb2312""?><root></root>"
   End If
End Sub

Rem 保存發送請求xml數據到文件，文件名為sendXML_日期.txt
Public Sub SaveSendXMLDataToFile()
   Dim filename,str
   filename = "sendXML_" & DateValue(now) & ".txt"
   str = ""
   str = str & ""& Now() & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   str = str & "<?XML version=""1.0"" encoding=""gb2312""?>" & vbNewLine
   str = str & XmlDoc.documentElement.XML & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   str = str & vbNewLine & vbNewLine & vbNewLine
   WriteStringToFile filename,str
End Sub

Rem 保存返回XML數據到文件，文件名為getXML_日期.txt
Public Sub SaveGetXMLDataToFile()
   Dim filename,str
   filename = "getXML_" & DateValue(now) & ".txt"
   str = ""
   str = str & ""& Now() & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   If IsObject(m_GetXMLDoc) Then
    str = str & "<?XML version=""1.0"" encoding=""gb2312""?>" & vbNewLine
    str = str & m_GetXmlDoc.documentElement.XML
   Else
    str = str & "<?XML version=""1.0"" encoding=""gb2312""?>" & vbNewLine & "<root>" & vbNewLine & "</root>"
   End If
   str = str & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   str = str & vbNewLine & vbNewLine & vbNewLine
   WriteStringToFile filename,str
End Sub

'--------------------------------------------------
'獲取返回XML的節點信息
'XMLClassObj.GetSingleNode("//msg")
'--------------------------------------------------
Public Function GetSingleNode(nodestring)
   If IsObject(m_GetXMLDoc) Then
    GetSingleNode = m_GetXMLDoc.documentElement.selectSingleNode(nodestring).text
   Else
    GetSingleNode = ""
   End If
End Function
''''''''''''''''''發送XML部分結束

''''''''''''''''''接收XML部分開始
'--------------------------------------------------
'接收XML包，錯誤信息通過Message對象獲取
'--------------------------------------------------
Public Function AcceptHttpData()
   Dim XMLdom
   Set XMLdom = Server.CreateObject("Microsoft.XMLDOM")
   XMLdom.Async = False
   XMLdom.Load(Request)
   If XMLdom.parseError.errorCode <> 0 Then
    MessageCode = "不能正確接收數據" & "Descript_ion: " & XMLdom.parseError.reason & "<br>Line: " & XMLdom.parseError.Line
    Set m_XMLDocAccept = Null
   Else
    Set m_XmlDocAccept = XMLdom
   End If
End Function

'--------------------------------------------------
'返回接收XML包節點信息
'XMLClassObj.GetSingleNode("//msg")
'--------------------------------------------------
Public Function AcceptSingleNode(nodestring)
   If IsObject(m_XMLDocAccept) Then
    AcceptSingleNode = m_XMLDocAccept.documentElement.selectSingleNode(nodestring).text
   Else
    AcceptSingleNode = ""
   End If
End Function

'--------------------------------------------------
'打印接收端接收到的XML數據
'--------------------------------------------------
Public Sub PrintAcceptXMLData()
   Response.Clear
   Response.ContentType = "text/XML"
   Response.CharSet = "gb2312"
   Response.Expires = 0
   If IsObject(m_XMLDocAccept) Then
    Response.Write "<?XML version=""1.0"" encoding=""gb2312""?>"&vbNewLine
    Response.Write m_XmlDocAccept.documentElement.XML
   Else
    Response.Write "<?XML version=""1.0"" encoding=""gb2312""?><root></root>"
   End If
End Sub

Rem 保存接收的XML包數據到文件，文件名為acceptXML_日期.txt
Public Sub SaveAcceptXMLDataToFile()
   Dim filename,str
   filename = "acceptXML_" & DateValue(now) & ".txt"
   str = ""
   str = str & ""& Now() & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   If IsObject(m_XMLDocAccept) Then
    str = str & "<?XML version=""1.0"" encoding=""gb2312""?>" & vbNewLine
    str = str & m_XmlDocAccept.documentElement.XML
   Else
    str = str & "<?XML version=""1.0"" encoding=""gb2312""?>" & vbNewLine & "<root>" & vbNewLine & "</root>"
   End If
   str = str & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   str = str & vbNewLine & vbNewLine & vbNewLine
   WriteStringToFile filename,str
End Sub

''''''''''''''''''接收XML部分結束

Rem 保存調試數據到文件，文件名為debugnote_日期.txt
Public Sub SaveDebugStringToFile(debugstr)
   Dim filename,str
   filename = "debugnote_" & DateValue(now) & ".txt"
   str = ""
   str = str & ""& Now() & vbNewLine
   str = str & "---------------------------------------------"& vbNewLine
   str = str & debugstr & vbNewLine
   str = str & "---------------------------------------------"
   str = str & vbNewLine & vbNewLine & vbNewLine
   WriteStringToFile filename,str
End Sub

'公共方法結束--------------------------

End Class
%>

測試用例：

sendXML.ASP

<%
Option Explicit

Response.buffer = True
Response.Expires=-1
%>

<%
Const Apisysno = "23498927347234234987"
Const ActionURL = "http://www.shouji138.com/aspnet2/acceptxml.asp" Rem 響應的文件寫url地址

Dim XMLClassObj
Set XmlClassObj = new XMLClass '創建對象
XmlClassObj.LoadXmlFromString("<?xml version=""1.0"" encoding=""gb2312""?><root/>") '用xml字符填充XMLDOC對象，用來發送XML
XMLClassObj.URL = ActionURL '設置響應的url

Rem XML格式
Rem "<?XML version="1.0" encoding="gb2312"?>
Rem   <root>
Rem    <sysno></sysno>
Rem    <username></username>
Rem    <pwd></pwd>
Rem    <email></email>
Rem    <pagename></pagename>
Rem    <pageurl></pageurl>
Rem   </root>

XMLClassObj.NodeValue "sysno",Apisysno,0,False
XMLClassObj.NodeValue "username","testusername",0,False
XMLClassObj.NodeValue "pwd","pwd",0,False
XMLClassObj.NodeValue "email","[email protected]",0,False
XMLClassObj.NodeValue "pagename","站點",0,False
XMLClassObj.NodeValue "pageurl","http://www.shouji138.com",1,False

XmlClassObj.SaveSendXmlDataToFile() '將發送的XML數據庫包存入txt文件

XmlClassObj.SendHttpData() '開始發送XML數據

'XmlClassObj.PrintGetXmlData()        '打印接收到的XML數據
'response.write XMLClassObj.Message       '打印錯誤信息
XmlClassObj.SaveGetXmlDataToFile()       '將接收到的XML數據庫存入txt文件
response.write XmlClassObj.GetSingleNode("//message")   '顯示收到的XML數據的msg節點的值
Set XMLClassObj = Nothing         '銷毀對象實例
%>

acceptXML.ASP

<%
Rem Api用戶注冊接口
%>
<%
Response.Expires= -1
Response.Addheader "pragma","no-cache"
Response.AddHeader "cache-control","no-store"
%>

<%
Rem XML格式
Rem "<?XML version="1.0" encoding="gb2312"?>
Rem   <root>
Rem    <sysno></sysno>
Rem    <username></username>
Rem    <pwd></pwd>
Rem    <email></email>
Rem    <pagename></pagename>
Rem    <pageurl></pageurl>
Rem   </root>
Const Apisysno = "23498927347234234987"

On Error Resume Next
Dim XMLClassObj
Set XmlClassObj = new XMLClass '創建對象
XmlClassObj.AcceptHttpData() '接收XML數據
XmlClassObj.SaveAcceptXmlDataToFile() '將接收到的XML數據存入txt文件
Err.clear
Dim message

Dim sysno,username,pwd,email,PageName,PageURL
sysno = XMLClassObj.AcceptSingleNode("//sysno")
username = XMLClassObj.AcceptSingleNode("//username")
pwd = XMLClassObj.AcceptSingleNode("//pwd")
email = XMLClassObj.AcceptSingleNode("//email")
PageName = XMLClassObj.AcceptSingleNode("//pagename")
PageURL = XMLClassObj.AcceptSingleNode("//pageurl")

XMLClassObj.SaveDebugStringToFile("sysno=" & sysno) '存入debug日志文件

If Err Then
message = message & Err.Descript_ion
Else
Err.clear
If sysno <> Apisysno Then
message = "請務非法使用！"
Else
message = regUser(username,pwd,email,PageName,PageURL)
End If
End If

'XMLClassObj.SaveDebugStringToFile("message=" & message) '將message值存入debug日志文件

Set XMLClassObj = Nothing '銷毀對象實例

Response.ContentType = "text/xml" '輸出XML數據流給發送端
Response.Charset = "gb2312"
Response.Clear
Response.Write "<?XML version=""1.0"" encoding=""gb2312""?>" & vbnewline
Response.Write "<root>" & vbnewline
Response.Write "<message>" & message & "</message>" & vbnewline
Response.Write "<nowtime>" & Now() & "</nowtime>" & vbnewline
Response.Write "</root>" & vbnewline

Function regUser(username,pwd,email,PageName,PageURL)
'''''''''''''''''''
''''''''''''''''''
'''''''''''''''''
'操作數據庫注冊用戶
'''''''''''''''''
''''''''''''''
regUser = "OK"

End Function
%>