このページを参考にしました。
Twitter API を OAuth で認証するスクリプトを 0 から書いてみた - trial and error
どうも。昨日もちょっと twitter に触れましたが、今日も twitter ねたです。
前の post で、チラッと触れた OAuth 認証 (O認証認証みたいでこわい) を使ってみたくなり、自分で 0 から書いて見ました。
windows2000、IE6、ms-office2000以降なら動くと思います。
Private Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" _
(ByRef pbBinary As Any, _
ByVal cbBinary As Long, _
ByVal dwFlags As Long, _
ByVal pszString As String, _
ByRef pcchString As Long _
) As Long
Private Const CRYPT_STRING_BASE64 As Long = 1
Private Const consumer_key = "consumer-key"
Private Const consumer_secret = "consumer-securet"
Private Const reqt_url = "http://twitter.com/oauth/request_token"
Private Const auth_url = "http://twitter.com/oauth/authorize"
Private Const acct_url = "http://twitter.com/oauth/access_token"
Private Const post_url = "https://twitter.com/statuses/update.xml"
Private Const frtl_url = "http://twitter.com/statuses/friends_timeline.xml"
'Proxyを使う場合はユーザ名：パスワードで指定
'Private Const proxy_user = ""
Sub test()
Dim XHR As New MSXML2.XMLHTTP 'IEのxmlHttpRequestと同じ（クッキー・プロキシも同じ設定を使う）
Dim param As Scripting.Dictionary
Dim reqdata As String
Dim digest As String
Dim buf() As Byte
Dim res As String
Dim XMLDOM As MSXML2.DOMDocument
Dim proxy_auth As String
Dim otoken As String, otoken_secret As String
Dim atoken As String, atoken_secret As String
Dim pin As String
If Len(proxy_user) > 0 Then
proxy_auth = EncodeBase64(StrConv(proxy_user, vbFromUnicode))
End If
Set param = CreateObject("Scripting.Dictionary")
'共通
param("oauth_consumer_key") = consumer_key
param("oauth_signature_method") = "HMAC-SHA1"
param("oauth_version") = "1.0"
'毎回必要
param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
param("oauth_nonce") = param("oauth_timestamp") * 333333 '適当にかぶらない数字
reqdata = "GET&" & UrlEncode(reqt_url) & "&" & UrlEncode(UrlParse(param))
digest = hmac(consumer_secret & "&", reqdata)
buf = StrToBynary(digest)
param("oauth_signature") = Trim(EncodeBase64(buf))
Call XHR.Open("GET", reqt_url & "?" & UrlParse(param), False)
If Len(proxy_user) > 0 Then
Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
End If
XHR.Send
Debug.Print "リクエストトークンをリクエスト レスポンスコード:"; XHR.status
'authトークン（一時的に使う為）
otoken = GetOAuthToken(XHR.ResponseText)
otoken_secret = GetOAuthToken_secret(XHR.ResponseText)
'PIN取得の為IEを起動（引数にauthトークンを指定）
Shell "c:\Program Files\Internet Explorer\iexplore.exe " & auth_url & "?oauth_token=" & otoken
pin = InputBox("pinを入力")
If pin = "" Then Exit Sub
'作り直し
param.Remove ("oauth_signature")
param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
param("oauth_nonce") = param("oauth_timestamp") * 333333
param("oauth_verifier") = pin '今回だけ（PINコード）
param("oauth_token") = otoken '今回だけ（authトークン）
reqdata = "GET&" & UrlEncode(acct_url) & "&" & UrlEncode(UrlParse(param))
digest = hmac(consumer_secret & "&" & otoken_secret, reqdata)
buf = StrToBynary(digest)
param("oauth_signature") = Trim(EncodeBase64(buf))
Call XHR.Open("GET", acct_url & "?" & UrlParse(param), False)
If Len(proxy_user) > 0 Then
Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
End If
XHR.Send
Debug.Print "アクセルトークンをリクエスト レスポンスコード:"; XHR.status
'アクセストークン（今のところ期限が無いので恒久的。次回はいきなり指定してもＯＫ）
atoken = GetOAuthToken(XHR.ResponseText)
atoken_secret = GetOAuthToken_secret(XHR.ResponseText)
'作り直し
param.Remove ("oauth_verifier")
param.Remove ("oauth_signature")
param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
param("oauth_nonce") = param("oauth_timestamp") * 333333
param("oauth_token") = atoken
param("count") = "50"
reqdata = "GET&" & UrlEncode(frtl_url) & "&" & UrlEncode(UrlParse(param))
digest = hmac(consumer_secret & "&" & atoken_secret, reqdata)
buf = StrToBynary(digest)
param("oauth_signature") = Trim(EncodeBase64(buf))
Call XHR.Open("GET", frtl_url & "?" & UrlParse(param), False)
If Len(proxy_user) > 0 Then
Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
End If
XHR.Send
Debug.Print "APIアクセス レスポンスコード:"; XHR.status
Dim status As MSXML2.IXMLDOMSelection
Dim texts As MSXML2.IXMLDOMElement
Dim i As Long
Set XMLDOM = XHR.responseXML
Set status = XMLDOM.getElementsByTagName("status")
For Each texts In status
Debug.Print ConvertCreateTime(texts.selectSingleNode("created_at").FirstChild.NodeValue);
Debug.Print texts.selectSingleNode("user/screen_name").FirstChild.NodeValue; ": ";
Debug.Print texts.selectSingleNode("text").FirstChild.NodeValue
Next
End Sub
'wsh機能を使う(JScript)
Private Function UrlEncode(strTarget As String) As String
Dim obj As Object
If Len(strTarget) = 0 Then Exit Function
Set obj = CreateObject("ScriptControl")
obj.Language = "JScript"
UrlEncode = obj.CodeObject.encodeURIComponent(strTarget)
End Function
'win32API(恐らくwin2000から動く)
Function EncodeBase64(bytTarget() As Byte) As String
Dim strBase64 As String
Dim lngBase64_Len As Long
Dim ret As Long
'必要な容量を計算
ret = CryptBinaryToString(bytTarget(0), UBound(bytTarget) + 1, CRYPT_STRING_BASE64, vbNullString, lngBase64_Len)
If ret Then
strBase64 = Space(lngBase64_Len)
ret = CryptBinaryToString(bytTarget(0), UBound(bytTarget) + 1, CRYPT_STRING_BASE64, strBase64, Len(strBase64))
End If
EncodeBase64 = Mid(strBase64, 1, lngBase64_Len - 3)
End Function
'keyをソートして配列を返す
Private Function KeySort(dic As Scripting.Dictionary) As Variant
Dim i As Long, j As Long
Dim varTemp As Variant
Dim varData As Variant
If dic Is Nothing And dic.Count = 0 Then
Exit Function
End If
varData = dic.Keys
'総当りでソート（バブルソート）
For i = 0 To dic.Count - 1
For j = i + 1 To dic.Count - 1
'比較
If varData(i) > varData(j) Then
varTemp = varData(i)
varData(i) = varData(j)
varData(j) = varTemp
End If
Next
Next
KeySort = varData
End Function
'dictionaryオブジェクトのキーをソートしてkey1=value1&key2=valu2...の文字列を返す
Private Function UrlParse(dictionary_object As Scripting.Dictionary) As String
Dim strReqData As String
Dim d As Variant
Dim i As Long
On Error Resume Next
d = KeySort(dictionary_object)
For i = 0 To UBound(d)
strReqData = strReqData & "&" & CStr(d(i)) & "=" & dictionary_object(d(i))
Next
If Err.Number = 0 Then
UrlParse = Mid(strReqData, 2)
Else
UrlParse = ""
End If
On Error GoTo 0
End Function
'暗号化
Private Function hmac(ByVal key As String, ByVal data As String) As String
Dim i As Integer
Dim hash As String
Dim key_byte() As Byte
Dim key_len As Long
Dim data_len As Long
Dim ipad(63) As Byte
Dim opad(63) As Byte
Dim key_hash() As Byte
Dim data_hash As String
If key = "" And data = "" Then Exit Function
key_len = Len(key)
key_byte = StrConv(key, vbFromUnicode)
If key_len > 64 Then
key_hash = StrToBynary(CreateSHA1Hash(key_byte))
key_len = 20
Else
key_hash = key_byte
End If
ReDim Preserve key_hash(63)
For i = key_len To 63
key_hash(i) = 0
Next
For i = 0 To 63
ipad(i) = 0
opad(i) = 0
Next
For i = 0 To 63
ipad(i) = key_hash(i) Xor &H36
opad(i) = key_hash(i) Xor &H5C
Next
data_hash = CreateSHA1Hash(CStr(ipad) & StrConv(data, vbFromUnicode))
hash = CreateSHA1Hash(CStr(opad) & CStr(StrToBynary(data_hash)))
hmac = hash
End Function
'バイト文字列からバイト配列を返す
Private Function StrToBynary(strHexString As String) As Byte()
Dim buf() As Byte
Dim i As Long
ReDim Preserve buf(Len(CStr(strHexString)) \ 2 - 1)
For i = 0 To Len(CStr(strHexString)) \ 2 - 1
buf(i) = CByte("&h" & Mid(CStr(strHexString), i * 2 + 1, 2))
Next
StrToBynary = buf
End Function
'TwitterAPIの作成日から日付型の変数を返す
Private Function ConvertCreateTime(strCreated_at As String) As Date
ConvertCreateTime = DateValue(Mid(strCreated_at, 5, 6) & Right(strCreated_at, 5)) + TimeValue(Mid(strCreated_at, 11, 9)) + TimeValue("09:00")
End Function
'TwitterAPIのレスポンスからTokenを抜き出す
Private Function GetOAuthToken(strTarget As String) As String
Dim s, a, v
s = Split(strTarget, "&")
For Each a In s
v = Split(a, "=")
If v(0) = "oauth_token" Then
GetOAuthToken = v(1)
Exit Function
End If
Next
End Function
'TwitterAPIのレスポンスからsecretを抜き出す
Private Function GetOAuthToken_secret(strTarget As String) As String
Dim s, a, v
s = Split(strTarget, "&")
For Each a In s
v = Split(a, "=")
If v(0) = "oauth_token_secret" Then
GetOAuthToken_secret = v(1)
Exit Function
End If
Next
End Function
0 件のコメント:
コメントを投稿