www.gusucode.com > 艺术签名文章资讯网源代码 > 艺术签名文章资讯网源代码/624/api/cls_api.asp
<% '========================================================= '-- File: cls_api.asp '-- Version: NewAsp Site Management System 2.1 sp1 '-- Date: 2006-10-11 '-- Script Written by newasp.net '========================================================= '-- Copyright (C) 2003,2006 NewAsp.Net. All rights reserved. '-- Web: http://www.newasp.net,http://www.newasp.cn '-- Email: newasp@163.com '-- 声明:本程序修改自动网论坛系统Api接口 '========================================================= Dim API_Path,API_Enable,API_ConformKey,API_Urls Dim API_Debug,API_LoginUrl,API_ReguserUrl,API_LogoutUrl API_Path = Newasp.InstallDir & "api/" LoadXslConfig() Class API_Conformity Public AppID,Status,GetData,GetAppid Private XmlDoc,XmlHttp Private MessageCode,ArrUrls,SysKey,XmlPath Private Sub Class_Initialize() GetAppid = "" AppID = "newasp" ArrUrls = Split(Trim(API_Urls),"|") Status = "1" SysKey = API_ConformKey MessageCode = "" XmlPath = API_Path & "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 "<?xml version=""1.0"" encoding=""gb2312""?><root/>" End If NodeValue "appID",AppID,1,False End Sub 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 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 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 'On Error Resume Next 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 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 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 & "<script language=""JavaScript"" src="""&Trim(ArrUrls(i))&"?syskey="&Server.URLEncode(C_Syskey)&"&username="&Server.URLEncode(C_UserName)&"&password="&Server.URLEncode(C_PassWord)&"&savecookie="&Server.URLEncode(C_SetType)&"""></script>" Next SetCookie = TempStr End Function Public Sub PrintGetXmlData() Response.Clear Response.ContentType = "text/xml" Response.CharSet = "gb2312" Response.Expires = 0 Response.Write "<?xml version=""1.0"" encoding=""gb2312""?>"&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 Sub LoadXslConfig() Dim XslDoc,XslNode,Xsl_Files Xsl_Files = API_Path & "api.config" Xsl_Files = Server.MapPath(Xsl_Files) Set XslDoc = Server.CreateObject("Msxml2.FreeThreadedDOMDocument" & MsxmlVersion) If Not XslDoc.Load(Xsl_Files) Then Response.Write "初始数据不存在!" Response.End Else Set XslNode = XslDoc.documentElement.selectSingleNode("rs:data/z:row") API_Enable = Newasp.ChkBoolean(XslNode.getAttribute("api_enable")) API_ConformKey = XslNode.getAttribute("api_conformkey") API_Urls = XslNode.getAttribute("api_urls") API_Debug = Newasp.ChkBoolean(XslNode.getAttribute("api_debug")) API_LoginUrl = XslNode.getAttribute("api_loginurl") API_ReguserUrl = XslNode.getAttribute("api_reguserurl") API_LogoutUrl = XslNode.getAttribute("api_logouturl") Set XslNode = Nothing End If Set XslDoc = Nothing End Sub %>