Office 365 APIをVBAから呼び出す(3)

ホーム
Office関連, Office 365
Office 365 APIをVBAから呼び出す(3)

2015.05.19

Office 365 APIをVBAから呼び出す(3)

前々回の記事でOffice 365とAzure ADの紐づけを、前回の記事でAPIを呼び出すアプリケーションの下準備として、リダイレクト URIの設定とクライアント IDの取得、アプリケーションの権限設定を行いました。
今回はいよいよVBAマクロからOffice 365 APIを呼び出してみます。

APIを呼び出す流れ

Office 365 APIを利用するには、authorization codeを取得してaccess tokenを取得して…といった作業が必要になりますが、どのような工程を経れば良いのかは「Office 365 app authentication concepts」にある表を見ると分かりやすいです。

大雑把に言うと、

Azure ADのエンドポイントにアクセスします。
無事に認証できるとauthorization codeが取得できます。
取得したauthorization codeを使って、Azure ADのエンドポイントにPOSTします。
問題が無ければaccess tokenやrefresh tokenを取得することができます。
access tokenを使ってAPIを呼び出します。

こんな感じです。
よくあるOAuth 2.0 認証のWeb APIと大体同じ流れですので、Web APIの呼び出しに慣れている人には難しくないだろうと思います。

VBAマクロのコード

上記の流れを踏まえて書いたコードが下記になります。
「Outlook Mail REST API」を使ってユーザーのメール一覧を取得するマクロです。

実行する際は「client_id」と「redirect_uri」をそれぞれ自分が取得・設定したものに置き換えてください。

また、コード中ScriptControlを使っているため、64ビット版のOfficeではエラーが発生します。

Option Explicit

Public Sub SampleOutlookAPI()
'サンプル - Outlook Mail REST API呼び出し
'※ ScriptControlを使っているため、32ビット環境のみ対応
'※ リダイレクト URIをlocalhostにしている場合は、ローカルサーバー(XAMPP他)の起動が必要な場合があります。
  Dim url_auth As String
  Dim url_token As String
  Dim url_api As String
  Dim q As String
  Dim code As String
  Dim js As String
  Dim access_token As String
  Dim dat As Variant
  Dim ary As Variant, ary2 As Variant
  Dim messages As Object
  Dim message As Object
  Dim i As Long
  Dim value, Subject, BodyPreview 'JSONパース用ダミー
  Const READYSTATE_COMPLETE = 4
  
  '**********************************************************************
  'クライアント ID & リダイレクト URI
  Const client_id As String = "(取得したクライアント ID)"
  Const redirect_uri As String = "(設定したリダイレクト URI)"
  '**********************************************************************
  
  'authorization code取得
  code = "" '初期化
  url_auth = "https://login.microsoftonline.com/common/oauth2/authorize?response_type=code" & _
             "&redirect_uri=" & EncodeURL(redirect_uri) & _
             "&client_id=" & client_id & _
             "&resource=" & EncodeURL("https://outlook.office365.com/")
  With CreateObject("InternetExplorer.Application")
    .Visible = True
    .Navigate url_auth
    While .ReadyState <> READYSTATE_COMPLETE Or _
          .Busy = True Or _
          (StrComp(Left(.LocationURL, Len(redirect_uri)), redirect_uri) <> 0)
      DoEvents
    Wend
    q = .document.parentWindow.Location.Search
    q = Mid(q, 2) '"?"削除
    ary = Split(q, "&")
    For i = LBound(ary) To UBound(ary)
      ary2 = Split(ary(i), "=")
      If LCase(ary2(0)) = "code" Then
        code = ary2(1)
        Exit For
      End If
    Next
    .Quit
  End With
  If Len(Trim(code)) < 1 Then Exit Sub
  
  'access token取得
  js = "": access_token = "" '初期化
  url_token = "https://login.microsoftonline.com/common/oauth2/token"
  dat = "grant_type=authorization_code" & _
        "&code=" & code & _
        "&client_id=" & client_id & _
        "&redirect_uri=" & EncodeURL(redirect_uri)
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", url_token, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send dat
    Select Case .Status
      Case 200: js = .responseText
    End Select
  End With
  If Len(Trim(js)) < 1 Then Exit Sub
  js = "(" & js & ")"
  With CreateObject("ScriptControl")
    .Language = "JScript"
    access_token = .CodeObject.eval(js).access_token
  End With
  If Len(Trim(access_token)) < 1 Then Exit Sub
  
  'Outlook Mail REST API呼び出し
  js = "" '初期化
  url_api = "https://outlook.office365.com/api/v1.0/me/messages"
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url_api, False
    .setRequestHeader "Authorization", "Bearer " & access_token
    .send
    Select Case .Status
      Case 200: js = .responseText
    End Select
  End With
  If Len(Trim(js)) < 1 Then Exit Sub
  js = "(" & js & ")"
  With CreateObject("ScriptControl")
    .Language = "JScript"
    Set messages = .CodeObject.eval(js).value
    For Each message In messages
      Debug.Print message.Subject, message.BodyPreview '件名・本文プレビュー列挙
    Next
  End With
End Sub

Private Function EncodeURL(ByVal Target As String) As String
'URLエンコード
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(Target)
  End With
End Function

上記コードを実行すると、下図のようなログイン画面が表示され、