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

本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

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

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","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"

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

'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