| 導購 | 订阅 | 在线投稿
分享
 
 
 

asp處理xml數據的發送、接收類

來源:互聯網  2008-08-05 07:05:04  評論

本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,"]]>","]]&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","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

本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,"]]>","]]&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包 [url=http://www.devdao.com/]http://www.devdao.com/[/url] '-------------------------------------------------- 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 = "[url=http://www.shouji138.com/aspnet2/acceptxml.asp]http://www.shouji138.com/aspnet2/acceptxml.asp[/url]" 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","[url=mailto:web@shouji138.com]web@shouji138.com",0,False[/url] XmlClassObj.NodeValue "pagename","站點",0,False XmlClassObj.NodeValue "pageurl","[url=http://www.shouji138.com]http://www.shouji138.com",1,False[/url] 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
󰈣󰈤
王朝萬家燈火計劃
期待原創作者加盟
 
 
 
>>返回首頁<<
 
 
 
 
 熱帖排行
 
王朝網路微信公眾號
微信掃碼關註本站公眾號 wangchaonetcn
 
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有