Office 365 unified APIをVBAから呼び出す

ホーム
Office関連, Microsoft Graph, Office 365
Office 365 unified APIをVBAから呼び出す

2015.05.22

Office 365 unified APIをVBAから呼び出す

前回の記事で、VBAからOffice 365 APIを呼び出す手順についてまとめました。
OAuth 2.0 認証 + RESTという一般的な方式で、言語環境を選ばず手軽に外部からOffice 365の情報を取得することができる、とても便利なAPIです。

しかし、Office 365の各サービスのAPIのほとんどは固有のエンドポイントを持っており、複数のサービスにまたがる処理を実行しようとすると、SharePointに行ってOneDriveに行ってOutlookに行って…というように、非常に手間が掛かります。

そこで登場したのが「Office 365 unified API」です。

unified、つまり統一されたエンドポイントが用意されたことで、複数のサービスにまたがる処理であっても、単一のエンドポイント「https://graph.microsoft.com/」にアクセスすればそれでOK！になったわけです。

これはとても便利！
・・・というわけで、早速“VBAから”使ってみることにしました。

VBAからのOffice 365 unified API呼び出し

※ Office 365とAzure ADの紐付けや設定については、ここでは詳しく説明しませんので、「Office 365 APIをVBAから呼び出す(1)」と「Office 365 APIをVBAから呼び出す(2)」をご参照ください。

Azure ポータルにサインインし、「Active Directory」から「ネイティブクライアントアプリケーション」を追加します。
「他のアプリケーションに対するアクセス許可」から「Office 365 unified API (preview)」を追加します。

今回はメール情報を取得するマクロを書く予定なので「デリゲートされたアクセス許可」から「Read and write access to user mail」を選択します。

「保存」ボタンをクリックして変更を保存します。アプリケーションの構成画面に表示されている「クライアント ID」と「リダイレクト URI」は後で必要になるので、どこかに控えておきます。

以上で準備作業は完了です。
次は実際にマクロを書いて実行してみます。

下記コードを標準モジュールに貼り付け、「client_id」と「redirect_uri」をそれぞれ自分が取得・設定したものに置きかえます。

Option Explicit

Public Sub SampleOutlookAPI()
'サンプル - Office 365 unified API(Messages)呼び出し
'※ 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://graph.microsoft.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
  
  'Office 365 unified API呼び出し
  js = "" '初期化
  url_api = "https://graph.microsoft.com/beta/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