asp处理xml数据的发送、接收类

核心提示：本asp类可以用来处理xml包的发送与接收，可用于各种异构系统之间API接口间通讯，asp处理xml数据的发送、接收类，以及处理Web Service的调用与接收，属性：URL : 发送xml的接收地址String只写Message : 系统错误信息String只读XmlNode:获取发送包XML中节点的值String

本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
%>
<!--#include file="xmlcls.asp"-->

<%
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","web@shouji138.com",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"
%>
<!--#Include File="xmlcls.asp"-->
<%
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
%>

下载地址:http://www.shouji138.com/files/Xmlcls.rar

演示地址:http://www.shouji138.com/aspnet2/sendxml.asp