なんとかVBAで出来ないかといろいろ調べて、何とかできました。
このページを参考にしました。
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"
Sub test()
Dim XHR As New MSXML2.XMLHTTP
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
otoken = GetOAuthToken(XHR.ResponseText)
otoken_secret = GetOAuthToken_secret(XHR.ResponseText)
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
param("oauth_token") = otoken
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
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
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
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
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
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
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
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
hmacは
前のエントリーのモジュールが必要です。
techmem0.blogspot.com
