本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
