程式師世界 >> 編程語言 >> 網頁編程 >> 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("scripting.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包
'--------------------------------------------------
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 = "不能正確接收數據" & "Description: " & 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.Description
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 %>