class_api.asp

网人分类信息5.0商业版。非常优秀的分类信息系统。比较少见。

<%

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

    Private Sub class_initialize()
		appid="WRMPS"
		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 API_Urls="" 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(WR_Setting(3)&"API/HiAPI/Request.xml")
		Else
			strXmlPath = Server.Mappath(WR_Setting(3)&"API/HiAPI/Response.xml")
		End If
		XmlDoc.Load(strXmlPath)
	End Sub
	'Post到远程以及接收处理的主函数
    Private Function SendPost(Url,strType)  
		reType=strType
        Dim XMLTemp,strXML
		Dim reMessage
		set XMLTemp = Server.CreateObject("Microsoft.XMLDOM")
		APIKey=MD5(1,UserName&API_Key)
		Call setNodeValue("username", UserName)
		Call setNodeValue("action", strType)
		Call setNodeValue("syskey", APIKey)
		Call setNodeValue("appid", appid)
		Select Case strType
			Case "reguser","update"
				Call setNodeValue("password", PassWord)
				Call setNodeValue("email", EMail)
				Call setNodeValue("question", Question)
				Call setNodeValue("answer", Answer)
				Call setNodeValue("truename", TrueName)
				Call setNodeValue("gender", Sex)
				Call setNodeValue("qq", QQ)
				Call setNodeValue("address", AddRess)
				Call setNodeValue("homepage", Web)
				Call setNodeValue("userstatus", UserStatus)
			Case "login" 
				Call setNodeValue("password", PassWord)
				Call setNodeValue("savecookie", CookieDate)
			Case "checkname"
				Call 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
			    Response.Write "<span style=""color:red;font-weight:bold"">·远程服务器端无响应，请确认目的地址存在</font>"
			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
			    Response.Write "<span style=""color:red;font-weight:bold"">·返回信息读取出错，请重试</font>"
			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
					Response.Write "<span style=""color:red;font-weight:bold"">·"&Lcase(dpo_appid) &" 错误提示："&reMessage&"</font>"
				Else 
					AddErrStr(Replace (reMessage,"<li>",""))
					ShowErr()
				End if
				Exit Function 
			End If 
        End If
 	    Set XMLTemp=Nothing 
    End Function 
	'返回信息到请求端
	Public Function SendResult(status,strMsg)
		Call setNodeValue("appid", appid)
		Call setNodeValue("status", status)
		Call setNodeValue("message",strMsg)
		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 Function
	'读取用户信息，并返回请求
	Public Sub GetUser()
		Call setNodeValue("username", UserName)
		Call setNodeValue("password", PassWord)
		Call setNodeValue("email", EMail)
		Call setNodeValue("question", Question)
		Call setNodeValue("answer", Answer)
		Call setNodeValue("truename", TrueName)
		Call setNodeValue("gender", Sex)
		Call setNodeValue("qq", QQ)
		Call setNodeValue("address", AddRess)
		Call setNodeValue("homepage", Web)
		Call setNodeValue("userstatus", UserStatus)
	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 = "·"&Lcase(dpo_appid)&"提示您："& Message 
        Else
            ErrStr = ErrStr & "_" & Message
        End If
		FoundErr=True
    End Sub
	'同上一函数
    Private Sub ShowErr()
			If ErrStr <> "" Then
				Dim errmsg,errmsg1,i
				errmsg=Split(ErrStr,"_")
				For i=0 to UBound(errmsg)
					If i=0 Then
						errmsg1=errmsg1&"·"&errmsg(i)
					Else
						errmsg1=errmsg1&"<br>·"&errmsg(i)
					End If
				Next
				Call WRMPS.ErrView(errmsg1,0)
			End If 
		FoundErr=True
		ErrStr=Empty
    End Sub
End Class 
%>