<%

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("scripting.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包
'--------------------------------------------------
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 = "不能正确接收数据" & "Description: " & 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
%>

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数据库包存入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         '销毁对象实例

%>

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