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

。

​

​

​參數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,"]]>","]]&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套件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"," [email protected]",0,False
XmlClassObj.NodeValue "pagename","站點",0,False
XmlClassObj.NodeValue "pageurl"," http://www.shouji138.com",1,False

XmlClassObj.SaveSendXmlDataToFile() '將發送的xml資料庫包存入

ObjmClassObj.SendHttpData() '開始傳送資料

'

.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
%>

下載位址:/u/info_img/2009-06/25/Xmlcls.rar

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