<% '========================================================= ' File: Cls_DvApi.asp ' Version:7.1.0 sp1 ' Date: 2006-3-28 ' Script Written by dvbbs.net '========================================================= ' Copyright (C) 2003,2006 AspSky.Net. All rights reserved. ' Web: http://www.aspsky.net,http://www.dvbbs.net ' Email: eway@aspsky.net '========================================================= Class DvApi Public AppID,Status,GetData,GetAppid Private XmlDoc,XmlHttp Private MessageCode,ArrUrls,SysKey,XmlPath Private Sub Class_Initialize() GetAppid = "" AppID = "Dvbbs" ArrUrls = Split(Trim(DvApi_Urls),"|") Status = "1" SysKey = DvApi_SysKey MessageCode = "" XmlPath = "dv_dpo/api_user.xml" XmlPath = Server.MapPath(XmlPath) Set XmlDoc = Server.CreateObject("msxml2.FreeThreadedDOMDocument" & MsxmlVersion) Set GetData = Server.Createobject("Scripting.Dictionary") XmlDoc.ASYNC = False LoadXmlData() End Sub Private Sub Class_Terminate() If IsObject(XmlDoc) Then Set XmlDoc = Nothing If IsObject(GetData) Then Set GetData = Nothing End Sub Public Sub LoadXmlData() If Not XmlDoc.Load(XmlPath) Then XmlDoc.LoadXml "" End If NodeValue "appID",AppID,1,False End Sub '-------------------------------------------------- '参数 : '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数据对象 '例: 'DvApi_Obj.GetAppid = "dvbbs" 'If DvApi_Obj.GetXmlData<>Null Then Response.Write DvApi_Obj.GetXmlData.xml '当GetXmlData不为NULL时,GetXmlData为XML对象 '-------------------------------------------------- Public Property Get GetXmlData() Dim GetXmlDoc GetXmlData = Null If GetAppid <> "" Then GetAppid = Lcase(GetAppid) If GetData.Exists(GetAppid) Then Set GetXmlData = GetData(GetAppid) End If End If End Property Public Sub SendHttpData() Dim i,GetXmlDoc,LoadAppid Set Xmlhttp = Server.CreateObject("MSXML2.ServerXMLHTTP" & MsxmlVersion) Set GetXmlDoc = Server.CreateObject("msxml2.FreeThreadedDOMDocument" & MsxmlVersion) For i = 0 to Ubound(ArrUrls) XmlHttp.Open "POST", Trim(ArrUrls(i)), false XmlHttp.SetRequestHeader "content-type", "text/xml" XmlHttp.Send XmlDoc 'Response.Write strAnsi2Unicode(xmlhttp.responseBody) If GetXmlDoc.load(XmlHttp.responseXML) Then LoadAppid = Lcase(GetXmlDoc.documentElement.selectSingleNode("appid").Text) GetData.add LoadAppid,GetXmlDoc Status = GetXmlDoc.documentElement.selectSingleNode("status").Text MessageCode = MessageCode & LoadAppid & "(" & Status &"):" & GetXmlDoc.documentElement.selectSingleNode("body/message").Text If Status = "1" Then '当发生错误时退出 Exit For End If Else Status = "1" MessageCode = "请求数据错误!" Exit For End If Next Set GetXmlDoc = Nothing Set XmlHttp = Nothing End Sub Public Property Get Message() Message = MessageCode End Property '-------------------------------------------------- '写COOKIE调用 '参数 'C_Syskey 密钥,C_UserName 用户名,C_PassWord 加密的用户密码 ,C_SetType 保存COOKIE时间 '-------------------------------------------------- Public Function SetCookie(Byval C_Syskey,Byval C_UserName,Byval C_PassWord,Byval C_SetType) Dim i,TempStr TempStr = "" For i = 0 to Ubound(ArrUrls) TempStr = TempStr & vbNewLine & "" Next SetCookie = TempStr End Function '-------------------------------------------------- '打印发送请求XML数据 '-------------------------------------------------- Public Sub PrintXmlData() Response.Clear Response.ContentType = "text/xml" Response.CharSet = "gb2312" Response.Expires = 0 Response.Write ""&vbNewLine Response.Write XmlDoc.documentElement.XML End Sub '-------------------------------------------------- '打印返回XML数据 'DvApi_Obj.GetAppid = "dvbbs" 'DvApi_Obj.PrintGetXmlData '-------------------------------------------------- Public Sub PrintGetXmlData() Response.Clear Response.ContentType = "text/xml" Response.CharSet = "gb2312" Response.Expires = 0 Response.Write ""&vbNewLine Response.Write GetXmlData.documentElement.XML End Sub 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 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 End Class %>