HTML文件中放置QQ登陸按鈕
<a href="redirect.asp" target=_self data-role="button" class="ui-btn-right" style="height:24px;line-height:24px;"><img src="Images/bt_blue.png" height="24" alt="QQ登錄" border="0"></a>
Redirect.asp文件內容如下：
<!--#include file="qqconnect.asp"-->
<%
Dim qc, url
Session("Code")=""
Session("Openid")=""
Session("Access_Token")=""
SET qc = New QqConnet
Session("State")=qc.MakeRandNum()
url = qc.GetAuthorization_Code()
Response.Redirect(url)
Set qc=Nothing
%>
qqconnect.asp內容如下：
<script language="jscript" runat="server">
function getjson(str){
try{
eval("var jsonStr = (" + str + ")");
}catch(ex){
var jsonStr = null;
}
return jsonStr;
}
</script>
<%
'==================================
'=類 名 稱：QqConnet
'=功 能：QQ登錄 For ASP
'=作 者：㊣FireFox㊣
'=Q Q: 63572063
'=日 期：2012-01-02
'==================================
'轉載時請保留以上內容！！
Class QqConnet
Private QQ_OAUTH_CONSUMER_KEY
Private QQ_OAUTH_CONSUMER_SECRET
Private QQ_CALLBACK_URL
Private QQ_SCOPE
Private oDic,aKeys,access_token,TimeLine,boundary
'銷毀對象
Private Sub Class_Terminate()
Set oDic = Nothing
End Sub
Private Sub Class_Initialize
QQ_OAUTH_CONSUMER_KEY = " "'APP ID
QQ_OAUTH_CONSUMER_SECRET = " "'APP KEY
QQ_CALLBACK_URL = " "'REDIRECT_URI
QQ_SCOPE ="get_user_info" '授權項 例如：QQ_SCOPE=get_user_info,list_album,upload_pic,do_like,add_t
'不傳則默認請求對接口get_user_info進行授權。
'建議控制授權項的數量，只傳入必要的接口名稱，因為授權項越多，用戶越可能拒絕進行任何授權。
TimeLine= DateDiff("s","01/01/1970 08:00:00",Now()) 'oauth_timestamp
boundary="------------------"&TimeLine
Set oDic = Server.CreateObject("Scripting.Dictionary")
End Sub
Property Get APP_ID()
APP_ID = QQ_OAUTH_CONSUMER_KEY
End Property
'生成Session("State")數據.
Public Function MakeRandNum()
Randomize
Dim width : width = 6 '隨機數長度,默認6位
width = 10 ^ (width - 1)
MakeRandNum = Int((width*10 - width) * Rnd() + width)
End Function
Private Function CheckXml()
Dim oxml,Getxmlhttp
On Error Resume Next
oxml=array("Microsoft.XMLHTTP","Msxml2.ServerXMLHTTP.6.0","Msxml2.ServerXMLHTTP.5.0","Msxml2.ServerXMLHTTP.4.0","Msxml2.ServerXMLHTTP.3.0","Msxml2.ServerXMLHTTP","Msxml2.XMLHTTP.6.0","Msxml2.XMLHTTP.5.0","Msxml2.XMLHTTP.4.0","Msxml2.XMLHTTP.3.0","Msxml2.XMLHTTP")
For i=0 to ubound(oxml)
Set Getxmlhttp = Server.CreateObject(oxml(i))
If Err Then
Err.Clear
CheckXml = False
Else
CheckXml = oxml(i) :Exit Function
End if
Next
End Function
'Get方法請求url,獲取請求內容
Private Function RequestUrl(url)
Set XmlObj = Server.CreateObject(CheckXml)
XmlObj.open "GET",url, false
XmlObj.send
If XmlObj.Readystate=4 Then
RequestUrl = XmlObj.responseText
Else
Response.Write("xmlhttp請求超時！")
Response.End()
End If
Set XmlObj = nothing
End Function
'Post方法請求url,獲取請求內容
Private Function RequestUrl_post(url,data)
Set XmlObj = Server.CreateObject(CheckXml())
XmlObj.open "POST", url, false
XmlObj.setrequestheader "POST"," /t/add_t HTTP/1.1"
XmlObj.setrequestheader "Host"," graph.qq.com "
XmlObj.setrequestheader "content-length ",len(data)
XmlObj.setRequestHeader "Content-Type "," application/x-www-form-urlencoded "
XmlObj.setrequestheader "Connection"," Keep-Alive"
XmlObj.setrequestheader "Cache-Control"," no-cache"
XmlObj.send(data)
If XmlObj.Readystate=4 Then
RequestUrl_post = XmlObj.responseText
Else
Response.Write("xmlhttp請求超時！")
Response.End()
End If
Set XmlObj = nothing
End Function
Private Function CheckData(data,str)
If Instr(data,str)>0 Then
CheckData = True
Else
CheckData = False
End If
End Function
'生成登錄地址
Public Function GetAuthorization_Code()
Dim url, params
url = "https://graph.qq.com/oauth2.0/authorize"
params = "client_id=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&redirect_uri=" & QQ_CALLBACK_URL
params = params & "&response_type=code"
params = params & "&scope="&QQ_SCOPE
params = params & "&state="&Session("State")
url = url & "?" & params
GetAuthorization_Code = (url)
End Function
'獲取 access_token
Public Function GetAccess_Token()
Dim url, params,Temp
Url="https://graph.qq.com/oauth2.0/token"
params = "client_id=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&client_secret=" & QQ_OAUTH_CONSUMER_SECRET
params = params & "&redirect_uri=" & QQ_CALLBACK_URL
params = params & "&grant_type=authorization_code"
params = params & "&code="&Session("Code")
url = Url & "?" & params
Temp=RequestUrl(url)
If CheckData(Temp,"access_token=") = True Then
GetAccess_Token=CutStr(Temp,"access_token=","&")
Else
Response.Write("獲取 Access_Token 時發生錯誤，錯誤代碼："&CutStr(Temp,"{""error"":",","))
Response.End()
End If
End Function
Sub setSession(str)
Dim ary1
ary1 = Split(Replace(str,"=","&"),"&")
If ubound(ary1) > 1 Then
Session("access_token") = ary1(1)
Session("expires_in") = ary1(3)
Session("refresh_token") = ary1(5)
End If
End Sub
'檢測是否合法登錄！
Public Function CheckLogin()
Dim Code,mState
Code=Trim(Request.QueryString("code"))
If Code<>"" Then
CheckLogin = True
Session("Code")=Code
Else
CheckLogin = False
End If
End Function
'獲取openid
Public Function Getopenid()
Dim url, params,Temp
url = "https://graph.qq.com/oauth2.0/me"
params = "access_token="&Session("Access_Token")
url = Url & "?" & params
Temp=RequestUrl(url)
If Instr(Temp,"openid")>0 Then
set obj = getjson(CutStr(Temp,"(",")"))
if isobject(obj) Then
Getopenid=obj.openid
End If
set obj = Nothing
Else
set obj = getjson(CutStr(Temp,"(",")"))
if isobject(obj) Then
ret = obj.error
msg = obj.error_description
End If
set obj = Nothing
Response.Write("獲取 openid 時發生錯誤，錯誤代碼："&ret&" , 錯誤描述："&msg)
Response.End()
End If
End Function
'發送一條微博
Public Function Post_Webo(content)
Dim url, params
url = "https://graph.qq.com/t/add_t"
params = "oauth_consumer_key=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&access_token=" & Session("Access_Token")
params = params & "&openid=" & Session("Openid")
params = params & "&content="&content
params = params & "&format=json"
Post_Webo = RequestUrl_post(url,params)
End Function
'發送一條說說
Public Function Post_add_topic(content)
Dim url, params
url = "https://graph.qq.com/shuoshuo/add_topic"
params = "oauth_consumer_key=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&access_token=" & Session("Access_Token")
params = params & "&openid=" & Session("Openid")
params = params & "&con="&content
params = params & "&format=json"
Post_add_topic = RequestUrl_post(url,params)
End Function
'分享內容到QQ空間
Public Function Post_Share(title,turl,comment,summary,images)
Dim url, params
url = "https://graph.qq.com/share/add_share"
params = "oauth_consumer_key=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&access_token=" & Session("Access_Token")
params = params & "&openid=" & Session("Openid")
params = params & "&title="&title
params = params & "&url="&turl
params = params & "&title="&title
params = params & "&comment="&comment
params = params & "&summary="&summary
params = params & "&images="&images
params = params & "&format=json"
Post_Share = RequestUrl_post(url,params)
End Function
'獲取用戶信息,得到一個json格式的字符串
Public Function GetUserInfo()
Dim url, params, result
url = "https://graph.qq.com/user/get_user_info"
params = "oauth_consumer_key=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&access_token=" & Session("Access_Token")
params = params & "&openid=" & Session("Openid")
url = url & "?" & params
Temp = RequestUrl(url)
If CheckData(Temp,"nickname") = False Then
set obj = getjson(Temp)
if isobject(obj) Then
ret = obj.ret
msg = obj.msg
End If
set obj = Nothing
Response.Write("獲取用戶信息時發生錯誤，錯誤代碼："&ret&" , 錯誤描述："&msg)
Response.End()
End If
GetUserInfo = Temp
End Function
'獲取騰訊微博登錄用戶的用戶資料,得到一個json格式的字符串
Public Function Get_Info()
Dim url, params, result
url = "https://graph.qq.com/user/get_info"
params = "oauth_consumer_key=" & QQ_OAUTH_CONSUMER_KEY
params = params & "&access_token=" & Session("Access_Token")
params = params & "&openid=" & Session("Openid")
params = params & "&format=json"
url = url & "?" & params
Get_Info = RequestUrl(url)
End Function
'獲取用戶名字,性別,從json字符串里截取相關字符
Public Function GetUserName(json)
Dim nickname,sex,obj
set obj = getjson(json)
if isobject(obj) Then
nickname = obj.nickname
sex = obj.gender
End If
set obj = Nothing
GetUserName = Array(nickname,sex)
End Function
'獲取用戶頭像
Public Function GetUserPhoto(json)
Dim userphoto,obj
set obj = getjson(json)
if isobject(obj) Then
userphoto = obj.figureurl_qq_1
End If
set obj = Nothing
GetUserPhoto = userphoto
End Function
Public Function CutStr(data,s_str,e_str)
If Instr(data,s_str)>0 and Instr(data,e_str)>0 Then
CutStr = Split(data,s_str)(1)
CutStr = Split(CutStr,e_str)(0)
Else
CutStr = ""
End If
End Function
'發送數據
Function doRequest(verb, resLoc, getData, objData, multi)
Dim aUrl,xmlhttp
If(getData <>"") then getData = "?"&getData
aUrl = resLoc & getData
Response.write aUrl & "<br>"
Set xmlhttp=Server.CreateObject("MSXML2.ServerXMLHTTP")
xmlhttp.Open verb,aUrl,false
If(verb = "POST") Then
If(multi) Then '如果是圖片
xmlhttp.setRequestHeader "Content-Type","multipart/form-data; boundary="&boundary
'圖片上傳處理
Else
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=utf-8"
End If
End If
xmlhttp.send(objData)
doRequest=xmlhttp.responseText
'Response.Write("測試信息，可注釋: " & Replace(Replace(doRequest,"<","<"),">",">") & "<br><br>一個在線格式化JSON數據的工具：http://jsonformatter.curiousconcept.com/<br><br>")
Set xmlhttp=Nothing
End Function
Function Sorts()
Dim i,arr(),aKeys,aItems
ReDim arr(oDic.Count-1)
aKeys = oDic.Keys
aItems = oDic.Items
For i=0 To oDic.Count-1
arr(i)=aKeys(i)&"="&strUrlEnCode(oDic.Item(aKeys(i)))
Next
Sorts=join(arr,"&")
End Function
'URL Encode，並將不需要轉換的再替換回來
Function strUrlEnCode(byVal strUrl)
strUrlEnCode = Server.URLEncode(strUrl)
strUrlEnCode = Replace(strUrlEnCode,"%5F","_")
strUrlEnCode = Replace(strUrlEnCode,"%2E",".")
strUrlEnCode = Replace(strUrlEnCode,"%2D","-")
strUrlEnCode = Replace(strUrlEnCode,"+","%20")
End Function
End Class
%>
點擊登陸后會在返回文件中附加Code=XXXX&State=XXXX內容，將此內容繼續進行處理，可獲得QQ圖片，名字等信息。
If Len(Code)>0 then '登陸成功
SET qc = New QqConnet
Session("Access_Token")=qc.GetAccess_Token()
Session("Openid")=qc.Getopenid()
UserInfo=qc.GetUserInfo()
UserName=qc.GetUserName(UserInfo)(0)
UserPhoto=qc.GetUserPhoto(UserInfo)
End if