自从很早以前出了个DPO的接口，感觉好像是把动网、网易、OBlog三个程序融合到了一起，但是刀刀他们所有的程序其实有严重的问题，根本就不能支持多个域名下面访问，花了两天的时间终于明白了程序运行的所以然，呵呵，下面是研究的过程，代码很粗糙先放出来先，至于多个域名下面的Cookies的问题还在解决中。
文件目录：
/API/Response.xml，Request.xml，API_Config.asp，API_Function.asp，API_Response.asp
Response.Xml，Reequest.Xml：跟原先的一样，不用做大的修改，只要把AppID改成你目前的程序就可以了；
API_Config.asp：主要就是路径改下，其他不变
API_Function.asp：模仿了感觉写的OBlog的程序代码
<%
ClassDPO_API_SHOP
PrivateObjHttp,XmlDoc,AppID,API_Key,StrXmlPath,ReType,APO_AppID
PrivateSubClass_Initialize()
AppID="shop"
'OnErrorResumeNext
SetobjHttp=Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
SetXmlDoc=Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
EndSub
'读取XML模板文件，当值为True时是请求信息模板，反之是返回信息模板
PublicSubLoadXmlFile(IsRequest)
IfIsRequestThen
StrXmlPath=Server.MapPath("/API/Request.xml")
Else
StrXmlPath=Server.Mappath("/Api/Response.xml")
EndIf
XmlDoc.Load(StrXmlPath)
EndSub
'返回信息到请求端
PublicFunctionSendResult(status,strMsg)
SetNodeValue"appid",AppID
SetNodeValue"status",status
SetNodeValue"message",strMsg
Response.ContentType="text/xml"
Response.Charset="gb2312"
Response.Clear
Response.Write"<?xmlversion=""1.0""encoding=""gb2312""?>"
Response.WriteXmlDoc.documentElement.xml
EndFunction
'将读取到XML模板中的各个元素赋值
PrivateFunctionSetNodeValue(StrNodeName,StrNodeValue)
IfIsNull(StrNodeValue)orStrNodeValue=""ThenExitFunction
'OnErrorResumeNext
XmlDoc.SelectSingleNode("//"&StrNodeName).text=StrNodeValue
IfErrThen
ErrMsg=ErrMsg&"写入信息发生错误。"
FoundErr=True
ExitFunction
EndIf
EndFunction
EndClass
%>
API_Response.asp：做了很大的改动，目前还不知道这样的改动是不是会造成程序不稳定，先发布出来先
<%@LANGUAGE=VBScriptCodePage=936%>
<!--#includefile="../Inc/Conn.asp"-->
<!--#includefile="../Inc/MD5.asp"-->
<!--#IncludeFile="API_Config.asp"-->
<!--#includefile="API_Function.asp"-->
<%
DimFoundErr,ErrMsg
DimAction,SysKey,UserNam,UserPass,AppID,UserMail,Question,Answer
DimXMLDom,ShopAPI
SetShopAPI=NewDPO_API_SHOP
ShopAPI.LoadXmlFileFalse
SetXMLdom=Server.CreateObject("Microsoft.XMLDOM")
XMLdom.Async=False
XMLdom.Load(Request)
IfAPI_Enable=FalseThen
ErrMsg=ErrMsg&"系统并未开启整合接口！"
FoundErr=True
ShopAPI.SendResult1,ErrMsg
SetShopAPI=Nothing
Response.End
EndIf
IfXMLdom.parseError.errorCode<>0Then
ErrMsg=ErrMsg&"接收数据出错，请重试！"
FoundErr=True
ShopAPI.SendResult1,ErrMsg
SetShopAPI=Nothing
Response.End
Else
Appid=XMLdom.documentElement.selectSingleNode("//appid").text
SysKey=XMLdom.documentElement.selectSingleNode("//syskey").text
Action=XMLdom.documentElement.selectSingleNode("//action").text
UserName=XMLdom.documentElement.selectSingleNode("//username").text
EndIf
IfChkSyskey=TrueThen
SelectCaseAction
Case"checkname"
CallCheckName()
Case"reguser"
CallRegUser()
Case"login"
CallLogin()
EndSelect
IfFoundErrThen
ShopAPI.SendResult1,ErrMsg
Else
ShopAPI.SendResult0,""
EndIf
Else
ShopAPI.SendResult1,"安全验证码不正确。"
EndIf
SetXMLDom=Nothing
SetShopAPI=Nothing
'**************************************************
'函数名：CheckName
'作用：判断用户名称是否可以注册
'**************************************************
FunctionCheckName()
SetRs=Conn.Execute("SelectUserNameFrom[User]WhereUserName='"&UserName&"'")
IfNot(Rs.EofOrRs.Bof)Then
ErrMsg=ErrMsg&"用户名已经存在，请更换。"
FoundErr=True
CheckName=True
Else
CheckName=False
EndIf
Rs.Close
SetRs=Nothing
EndFunction
'**************************************************
'函数名：CheckEMail
'作用：判断用户邮件是否可以注册
'**************************************************
FunctionCheckEMail()
UserMail=XMLdom.documentElement.selectSingleNode("//email").text
SetRs=Conn.Execute("SelectUserMailFrom[User]WhereUserMail='"&UserMail&"'")
IfNot(Rs.EofOrRs.Bof)Then
ErrMsg=ErrMsg&"邮件地址已经存在，请更换。"
FoundErr=True
CheckEMail=True
Else
CheckEMail=False
EndIf
Rs.Close
SetRs=Nothing
EndFunction
'**************************************************
'函数名：RegUser
'作用：注册新的登录帐号
'**************************************************
FunctionRegUser()
IfCheckName=TrueOrCheckEMail=TrueThen
FoundErr=True
ExitFunction
EndIf
CallGetXML()
SetRs=Server.CreateObject("Adodb.RecordSet")
Sql="Select*From[User]"
Rs.OpenSql,Conn,1,3
Rs.AddNew
Rs("UserName")=UserName
Rs("UserPass")=MD5(UserPass,32)
Rs("UserMail")=UserMail
Rs("Question")=Question
Rs("Answer")=MD5(Answer,32)
Rs.UpDate
Rs.Close
SetRs=Nothing
FoundErr=False
EndFunction
'**************************************************
'函数名：Login
'作用：用户登录系统
'**************************************************
FunctionLogin()
PassWord=XMLdom.documentElement.selectSingleNode("//password").text
IfUserName=""Then
ErrMsg=ErrMsg&("登录名称不能为空。")
FoundErr=True
ExitFunction
EndIf
IfPassWord=""Then
ErrMsg=ErrMsg&("登录密码不能为空。")
FoundErr=True
ExitFunction
EndIf
PassWord=Md5(PassWord,32)
SetRs=Server.CreateObject("Adodb.RecordSet")
Sql="SelectUserName,UserPassFrom[User]WhereUserName='"&UserName&"'"
Rs.OpenSql,Conn,1,3
IfNot(Rs.EofOrRs.Bof)Then
IfRs("UserPass")=PassWordThen
Response.Cookies("SunLeaf_User").Domain="."
Response.Cookies("SunLeaf_User").Expires=DateAdd("d",1,Now)
Response.Cookies("SunLeaf_User")=UserName
Else
ErrMsg=ErrMsg&"登录密码错误。"
FoundErr=True
EndIf
Else
ErrMsg=ErrMsg&"登录帐号不存在。"
FoundErr=True
EndIf
Rs.Close
SetRs=Nothing
EndFunction
'**************************************************
'函数名：GetXML
'作用：接收提交过来的XML数据
'**************************************************
FunctionGetXML()
OnErrorResumeNext
UserPass=XMLdom.documentElement.selectSingleNode("//password").text
UserMail=XMLdom.documentElement.selectSingleNode("//email").text
Question=XMLdom.documentElement.selectSingleNode("//question").text
Answer=XMLdom.documentElement.selectSingleNode("//answer").text
EndFunction
'**************************************************
'函数名：ChkSyskey
'作用：判断API_KEY是否一致
'**************************************************
FunctionChkSyskey()
IfIsNull(UserName)orUserName=""orIsNull(SysKey)orSysKey=""Then
ChkSyskey=False
ExitFunction
EndIf
SysKey=LCase(SysKey)
IfLen(SysKey)=32ThenSysKey=Mid(SysKey,9,16)
DimStrEnKey
StrEnKey=Md5(UserName&API_Key,16)
IfLCase(SysKey)=LCase(StrEnKey)Then
ChkSyskey=True
Else
ChkSyskey=False
EndIf
EndFunction
%>
目前存在问题：不能在多个域名下面同时登录，即使是二级域名好像也不可以，真是奇怪了不知道是什么地方的问题，还在解决中。去刀刀博客上面找了下面，好像只有数据同步的工具也没有说在多个域名下面运行这个程序的说，怪怪怪。
