VB/VBAでTwitter

なんとか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"

'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

hmacは前のエントリーのモジュールが必要です。

Scripting.Dictionaryオブジェクトのソート

あまり必要ありませんが、何かに使えるかもしれないのでメモ。

バリアント配列の初期化に誤りがあったので修正

Private Sub DicSort(ByRef dic As Scripting.Dictionary)
  Dim i As Long, j As Long
  Dim d As Variant
  Dim varTemp As Variant
  Dim varData() As Variant
  
  If dic Is Nothing And dic.Count = 0 Then
    Exit Sub
  End If
  
  'バリアント二次元配列
  ReDim varData(dic.Count - 1 , 1)
  i = 0
  For Each d In dic
    varData(i, 0) = d
    varData(i, 1) = dic(d)
    i = i + 1
  Next
  
  '総当りでソート（バブルソート）
  For i = 0 To dic.Count - 1
    For j = i + 1 To dic.Count - 1
      '比較
      If varData(i, 0) > varData(j, 0) Then
        '次の配列の値が小さい場合は入替
        varTemp = Array(varData(i, 0), varData(i, 1))
        varData(i, 0) = varData(j, 0)
        varData(i, 1) = varData(j, 1)
        varData(j, 0) = varTemp(0)
        varData(j, 1) = varTemp(1)
      End If
    Next
  Next
  
  dic.RemoveAll
  
  For i = 0 To UBound(varData)
    dic(varData(i, 0)) = varData(i, 1)
  Next
End Sub

エラーチェックはしていません。

vbaでhmac

とある事情からvbaのみでhmacができないか調べました。
で、できました。

スーの道具箱/気まぐれ日記/2007-03-08

VBでハッシュを求める *
MD5をVBで処理すると遅くなってしまうので、advapi32.dllを使うと簡単だし速い。
あまりサンプルが見当たらなかったので、書いてみた

ここからコピペして標準モジュールへ貼り付け。
おそらくExcel2000以上で動くと思います。
(vba6なら動くと思います)

Public 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

ここを参考にしました。
【Access】vbaでhmacが正しく計算できた！！ | ﾌﾟﾗﾌﾟﾗ式技術系 Access流!
HMAC SHA256 BASE64: 逢魔時 ～トワイライト～