本asp類可以用來處理xml包的發送與接收?？捎糜诟鞣N異構系統之間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("scr   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,"]]>","]]&gt;"))
    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("http://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("http://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 = "

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","數據庫包存入txt文件

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

'XmlClassObj.PrintGetXmlData()        '打印接收到的xml數據
'response.write XmlClassObj.Message       '打印錯誤信息
XmlClassObj.SaveGetXmlDataToFile()       '將接收到的xml數據庫存入txt文件
response.write XmlClassObj.GetSingleNode("http://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("http://sysno")
username = XmlClassObj.AcceptSingleNode("http://username")
pwd = XmlClassObj.AcceptSingleNode("http://pwd")
email = XmlClassObj.AcceptSingleNode("http://email")
PageName = XmlClassObj.AcceptSingleNode("http://pagename")
PageURL = XmlClassObj.AcceptSingleNode("http://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