class_api.asp

来自「实现一个用JSP、Servlet技术实现的小型物流网站系统。实现功能如下：管理员」· ASP 代码 · 共 208 行

<%
'*********************************************************
'File:			Class_API.asp
'Description:	DPO_API Class For oBlog4.0
'Author:		感觉
'HomePage:		http://www.oblog.cn
'BBS			http://bbs.oblog.cn
'Copyright (C)	2004-2005 oblog.cn All rights reserved.
'LastUpdate:	20060913
'*********************************************************

Class DPO_API_OBLOG
	Private objHttp,XmlDoc,appid,API_Key,strXmlPath,reType,dpo_appid
	Public UserName,PassWord,CookieDate,EMail,Question,Answer,userip,Status,ErrStr,FoundErr
	Public Sex,QQ,MSN,UserStatus,TrueName,Birthday,TelePhone,HomePage,Province,City,address

    Private Sub class_initialize()
		appid="oblog4"
		On Error Resume Next
		Set objHttp = Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
		Set XmlDoc =Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
	End Sub
	Private Sub class_terminate()
		On Error Resume Next
		If IsObject(objHttp) Then set objHttp = Nothing
		If IsObject(XmlDoc) Then set XmlDoc = Nothing
	End Sub
	'分割配置文件中的url，将值分别提交到每个url中
	Public Function ProcessMultiPing(strType)
		Dim i,strUrl
		If strTargetUrls="" Then Exit Function
		For i=0 To UBound(aUrls)
			strUrl=Lcase(aUrls(i))
			If Left(strUrl,7)="http://" Then
				Call SendPost(strUrl,strType)
			End If
		Next
	End Function
	'读取XML模板文件，当值为True时是请求信息模板，反之是返回信息模板
	Public Sub LoadXmlFile(IsRequest)
		If IsRequest Then
			strXmlPath = Server.MapPath(""&blogdir&"api/Request.xml")
		Else
			strXmlPath = Server.Mappath(""&blogdir&"api/Response.xml")
		End If
		XmlDoc.Load(strXmlPath)
	End Sub
	'Post到远程以及接收处理的主函数
    Private Function SendPost(Url,strType)  
		reType=strType
        Dim XMLTemp,strXML
		Dim reMessage
		Dim ajax
		set ajax=new AjaxXml
		API_Key=MD5(UserName&oblog_Key)
		set XMLTemp = Server.CreateObject("Microsoft.XMLDOM")
		setNodeValue "username", UserName
		setNodeValue "action", strType
		setNodeValue "syskey", API_Key
		setNodeValue "appid", appid
		Select Case strType
			Case "reguser","update"
				setNodeValue "password", PassWord
				setNodeValue "email", EMail
				SetNodeValue "question", Question
				setNodeValue "answer", Answer
				setNodeValue "gender", Sex
				setNodeValue "birthday", Birthday
				setNodeValue "qq", QQ
				setNodeValue "msn", MSN
				setNodeValue "telephone", TelePhone
				setNodeValue "homepage", HomePage
				setNodeValue "userip", userip
				setNodeValue "userstatus", UserStatus
				setNodeValue "province", Province
				setNodeValue "city", city
				setNodeValue "address", address
			Case "login" 
				setNodeValue "password", PassWord
				setNodeValue "savecookie", CookieDate
				setNodeValue "userip", userip
			Case "checkname"
				setNodeValue "email", email
			Case Else
		End Select 
		On Error Resume Next   
        objHttp.Open "POST", Url, False, "", ""  
'		objHttp.setRequestHeader "Content-Type", "text/xml"
        objHttp.Send XmlDoc
		If objHttp.readystate<>4 Then
			'AJAX处理注册，登录以及验证用户的返回信息
			If reType="reguser" Or reType="checkname" Then
				ajax.re(split(objHttp.readystate &"远程服务器端无响应，请确认目的地址存在！$$$","$$$")) 
				response.End
			Else 
				AddErrStr("远程服务器端无响应，请确认目的地址存在！")
				showErr()
			End if
			Exit Function 
		End If    
'		Response.write objHttp.Responsetext
'		Response.End
		XMLTemp.Async=True
		XMLTemp.ValidateOnParse=False
		XMLTemp.Load(objHttp.ResponseXML)
		If XMLTemp.parseError.errorCode <> 0 Then
			'AJAX处理注册，登录以及验证用户的返回信息
			If reType="reguser"  Or reType="checkname" Then
					ajax.re(split("返回信息读取出错，请重试！$$$","$$$")) 
					response.End
			Else 
				AddErrStr("返回信息读取出错，请重试！")
				AddErrStr(XMLTemp.ParseError.ErrorCode)
				AddErrStr(XMLTemp.ParseError.Reason)
				ShowErr()				
			End if
			Exit Function 
        Else
			If XMLTemp.getElementsByTagName("status").item(0).text<>0 Then 
				dpo_appid=XMLTemp.getElementsByTagName("appid").item(0).text
				reMessage=XMLTemp.getElementsByTagName("message").item(0).text
				'AJAX处理注册，登录以及验证用户的返回信息
				If reType="reguser" Or reType="checkname" Then
					ajax.re(split(dpo_appid &"错误提示：<br />"&reMessage&"$$$","$$$")) 
					Response.end
				Else 
					AddErrStr(Replace (reMessage,"<li>",""))
					ShowErr()
				End if
				Exit Function 
			End If 
        End If
 	    Set XMLTemp=Nothing 
    End Function 
	'返回信息到请求端
	Public Function SendResult(status,strMsg)
		setNodeValue "appid", appid 
		setNodeValue "status", status 
		setNodeValue "message",strMsg 
		Response.ContentType = "text/xml"
		Response.Charset = "gb2312"
		Response.Clear
		Response.Write "<?xml version=""1.0"" encoding=""gb2312""?>"
		Response.Write XmlDoc.documentElement.xml 
	End Function
	'读取用户信息，并返回请求
	Public Sub GetUser()
		Call SetNodeValue("username", UserName)
		Call SetNodeValue("email", Email)
		Call SetNodeValue("question", Question)
		Call SetNodeValue("answer", Answer)
		Call SetNodeValue("savecookie", CookieDate)
		Call SetNodeValue("truename", TrueName)
		Call SetNodeValue("gender", Sex)
		Call SetNodeValue("birthday", Birthday)
		Call SetNodeValue("qq", QQ)
		Call SetNodeValue("msn", MSN)
		Call SetNodeValue("telephone", Telephone)
		Call SetNodeValue("homepage", Homepage)
		Call SetNodeValue("userip", UserIP)
		Call SetNodeValue("userstatus", userstatus)
		Call SetNodeValue("province", province)
		Call SetNodeValue("city", city)
		Call SetNodeValue("address",address)
	End Sub
	'将读取到XML模板中的各个元素赋值	
	Private Function SetNodeValue(strNodeName,strNodeValue)
		If IsNull(strNodeValue) or strNodeValue = "" Then Exit Function
		On Error Resume Next
		XmlDoc.selectSingleNode("//"& strNodeName).text = strNodeValue
		If Err Then
			AddErrStr("写入信息发生错误，请重试！")
			showErr() 
			Exit Function
		End If
	End Function
	'错误处理函数
    Private Sub AddErrStr(Message)
        If ErrStr = "" Then
            ErrStr = dpo_appid &"提示您："& Message 
        Else
            ErrStr = ErrStr & "_" & Message
        End If
		FoundErr=True
    End Sub
	'同上一函数
    Private Sub ShowErr()
		If reType<>"checkname" Then 
			If ErrStr <> "" Then Response.Redirect ""&blogdir&"err.asp?message=" & ErrStr
		Else
			If ErrStr <> "" Then
				Dim errmsg,errmsg1,i
				errmsg=Split(ErrStr,"_")
				For i=0 to UBound(errmsg)
					If i=0 Then
						errmsg1=errmsg1&"<li>"&errmsg(i)
					Else
						errmsg1=errmsg1&"<br><li>"&errmsg(i)
					End If
				Next
				response.Write(errmsg1)
			End If 
		End If 
		FoundErr=True
		ErrStr=Empty
    End Sub
End Class 
%>