VBAとMicrosoft Graph APIの連携 – Calendar編
MicrosoftのOutlookには予定表としてカレンダーが用意されています。VBAで何がしかの処理をした際にその記録として、カレンダーに残りしたり、タスクの開始と終了をカレンダーに自動登録しておいて、リマインダーを送らせたりしたい場合があります。
また、他の人が自身の標準カレンダーへのアクセス権限を限定公開したい場合もこの操作のうちに入ります。今回はこの予定表の読み書きやカレンダー共有設定をVBAから行ってみたいと思います。
リンク
目次
今回利用するサービスやファイル等
- Graph APIで読み書きサンプル – Excelファイル
- Microsoft Graph API
- Microsoft365 Calendar
- pkg – npm
- Graph API認証用のEXE
- Puppeteer-core
- VBA-JSON
以下のエントリーにあるようにPuppeteerを利用したOAuth2.0認証をするように変更しています。Node.jsにて作成し、EXEにパッケージ。これをVBAから叩いて利用しています。Graph API認証用のEXEはサンプルファイルと同じディレクトリに入れておく必要があります。
新方式が登場しました
IE11の廃止に伴い、SeleniumやNode.jsやらといった手段を使わず、またPuppeteerと同様の手法（CDPを叩く）でVBAとEdge/ChromeのみでOAuth2.0認証する手段が登場しました。スクレイピングも可能になっています。以下のエントリーを参考にしてみてください。この手法は最も制限が無く、もっともすぐれた選択肢になると思います。
事前準備
これまで、ElectronやGoogle Apps ScriptなどでGraph APIを叩く準備は構築してきていますが、VBAからも同じような形で事前準備が必要になります。以下の手順でClient IDとClient Secretを取得します（実用時はAccess Tokenなどの暗号化などの対処が別途必要になります）。
プロキシー設定を調べる
企業内で使う場合、ウェブアクセスにプロキシーを使ってる場合には、VBAからアクセスする場合もその設定を利用する必要性があります。プロキシーを経由しなければ外に出ることができないので、プログラムが動作しません。プロキシーの設定はいろいろなパターンがありますが、一般的な設定の調べ方は以下の通り。
サーバーのアドレスとポート番号について、http://を除外して、コロンでポート番号でつなげて利用します。（例：hiroproxy.net:8080）
- コントロールパネルより「インターネットオプション」を開く
- 「接続」タブを開き、「LANの設定」を開く
- この画面でプロキシーサーバの部分にアドレスとポート名が入ってるならばこれを控えておく。
- 場合によっては、詳細設定の中の「HTTP」で指定してるサーバーアドレスとポート番号を控えておく。
- 自動構成スクリプトを使ってる場合、そこに指定されてるアドレスのファイルの中に、様々なプロキシーアドレスが入っていますので、それを一旦ダウンロードして中身をテキストエディタで開いてみる（通常はpacというファイル）
- 5.のケースの場合、pacファイル内はIF文を使ってアクセスするサイト別にプロキシーが設定されてることが多いので、もっとも一般的なサイトアクセスもしくはBoxについてだけ定義している場合には、そのサーバーアドレスとポート番号を控えておく。
なお、Proxyを使わない場合には、コード内のproxyuriおよびWinHTTPの.setProxy 2, proxyuriについては、コメントアウトしておかないと「定数式が必要です」というエラーが出てしまうので注意してください。
図：プロキシー設定がない場合はこの作業は不要です。
Calendar IDについて
Calendarを操作する場合、自身の予定表に複数のカレンダーを追加してる場合であれ、そうでない場合であれ、各カレンダーには固有のIDが振られています。これがなければ操作ができないのですが、事前に調べて入れておくといった事ができない為、カレンダー名で一度対象のカレンダーのIDを取得しておいて、再度読み書きのリクエストを送ることになります。
また、今回はカレンダーの共有設定については、所属組織内の人のアクセス権限を操作するので、nameが「My Organization」のものを操作し、カレンダーは初期表示の「予定表」を操作します。
図：所属組織内の権限を変更する
Azureでプロジェクトを作成
今回のプログラムは管理者権限は不要です（Graph Explorerだと管理者権限の必要なスコープが出てきますが、実際には不要です）
- アプリの登録にて登録を開始する
- 新規登録をクリックする
- 名前を入力（今回はcalendarmanと入力しました）、リダイレクトURIは「webを選択」し、今回URLはこのサイトのURLを入力。
- 登録ボタンをクリックする
- 出てきた中で、「アプリケーション（クラと書かれているのがクライアントID」なので、このコードをメモしておく
- 左サイドバーより、「証明書とシークレット」をクリック
- 「新しいクライアントシークレット」をクリックする
- 今回は特に有効期限を設けないで追加をクリック
- これで「値」に「クライアントシークレット」が生成されて手に入りました。このシークレットはこの時だけしか表示されないので、注意してください（IDは不要なのでメモらなくていいです）
- つづけて、左サイドバーより「APIのアクセス許可」をクリックする
- Microsoft APIの中にある「Microsoft Graph」をクリックする。
- 「委任されたアクセス許可」をクリックする
- デフォルトでUser.ReadがすでにONなので、今回はopenid, offline_access, profile, Calendars.ReadWriteを検索してONにしましょう。
- アクセス許可の追加をクリックする
- 追加出来たら、xxxxxに管理者の同意を与えますをクリックします。すると、状態が緑色になります。今回は管理者の権限を要求するものは無いのでしなくても大丈夫だと思う
- 次に左サイドバーより「認証」をクリック
- 暗黙の付与にて、「アクセストークン」にチェックを入れる
- サポートされているアカウントの種類に於いては、「マルチテナント」にしておきました。
- 保存をクリック
- 概要のエンドポイントをクリックすると、いろいろなエンドポイントURLが出る。
- 概要のディレクトリ（テナントの数値はメモっておきます。あとでプログラム中で使用します。
- デフォルトでは組織アカウントでなければOAuth2.0認証が出来ません。
※3.でWebを選ばないSPAを選んでしまうと、Proof Key for Code Exchange by OAuth Public Clientsといったエラーが出てしまい認証ができませんので注意。
図：アプリの登録から全ては始まります。
図：Graphを選択する
図：アクセス権限付与した状態
図：認証の設定変更に注意
Excelファイルへ記述
今回はExcelファイルの標準モジュールの上部に記載しますが、通常はこの手の値は、外部のファイルへ切り出しておいたほうが安全ですので、iniファイル等やレジストリ等に値は保存し、読み書きする仕組みを用意しておくと良いでしょう。
auth3のモジュールの冒頭に4つの値を書き込みます。
|
1 2 3 4 5 6 |
'OAuth認証用 Public Const tenant As String = "ここにテナントIDを入れる" Public Const client_id As String = "ここにクライアントIDを入れる" Public Const client_secret As String = "ここにクライアントシークレットを入れる" Public Const redirecturl As String = "ここにリダイレクトURLを入れる" Public Const scope As String = "User.Read%20offline_access%20profile%20openid%20Calendars.ReadWrite" |
Scopeは%20で区切って入れておく必要があります。
認証を実行するコード
今回はNode.js + Puppeteer + pkgにてWindows用のEXEを作っており、VBAから叩いてAuthcodeを取得する所まではそちらで対応しています。以前にも全く同じ内容の手順を記述していますので、以下のエントリーを参考にしてみてください。
Authcodeを取得したら、続けて、Access TokenやRefresh Tokenを取得する仕組みになっています。
図：認証を実行する一歩手前
Calendarを読み書きしてみる
カレンダーIDを取得する
今回はいくつかあるカレンダーのうち「予定表」と名前のついてるデフォルトのカレンダーのIDを取得します。このIDはイベント登録等で利用するので、取得したらグローバルの変数やiniファイルに記述しておくと良いでしょう。このAPIについてはこちらにマニュアルがあります。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
'カレンダーの一覧を取得する Public Function getCalendarList() 'リクエストエンドポイントを構築 Dim requrl As String Dim calid As String requrl = endpoint & "me/calendars" 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'JSONをパースする用の変数 Dim Json Dim tempid As String Dim calname As String Dim calendarid As String 'HTTPリクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Authorization", "Bearer " & access_token .send '返ってきた値をもとにデータを処理 Select Case .Status Case 200 '返ってきたJSON文字列を取得 Set Json = JsonConverter.ParseJson(.ResponseText) 'JSONの中でvalueの中身を取得する For Each records In Json("value") 'idを取得する tempid = records("id") 'カレンダー名を取得 calname = records("name") '予定表のものをピックアップ If calname = "予定表" Then calendarid = tempid Exit For End If Next 'Token情報をiniファイルに書き込み IniWrite "USER", "calendarid", calendarid '終了処理 MsgBox "カレンダーIDの取得が完了しました。" Case Else MsgBox .Status & "エラー。カレンダーIDの取得に失敗しました。" End Select End With End Function |
- これで長いカレンダーIDが取得できますので、次項の読み書きが可能になります。基本最初の一度だけで良いので、何回も使う機会は無いと思います。
- レスポンスはJSONで返ってくるので、valueの配列を取得させ、その中にあるidという項目とnameという項目を取得し、予定表という名前のものだけをピックアップします。
カレンダーイベントを登録をする
既存の予定表に対して、カレンダーのスケジュールを登録します。今回は単品で登録するだけなので、例えば複数期間に渡っての登録や、パターン登録、グループカレンダー登録ではありません。こちらにマニュアルが掲載されています。既存の予定表以外のカレンダーに登録する場合は、カレンダーIDが必要になります。
今回は開始日、終了日、表題、場所の4点を登録します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
'カレンダーにイベントを登録する Public Function setCalEvent() 'リクエストエンドポイントを構築 Dim requrl As String Dim calid As String requrl = endpoint & "me/calendars" 'カレンダーIDを指定する場合 calid = IniRead("USER", "calendarid", "") requrl = endpoint & "/me/calendars/" & calid & "/events" 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'リクエストボディ Dim JsonObject As Object Set JsonObject = New Dictionary JsonObject.Add "subject", "ランチの予定" 'Subjectの指定 'ロケーションの指定 Dim location As Object Set location = New Dictionary location.Add "displayName", "焼肉キング" JsonObject.Add "location", location '開始日の指定 Dim startentry As Object Set startentry = New Dictionary startentry.Add "dateTime", "2022-08-21T12:00:00" startentry.Add "timeZone", "Asia/Tokyo" JsonObject.Add "start", startentry '終了日の指定 Dim endentry As Object Set endentry = New Dictionary endentry.Add "dateTime", "2022-08-21T13:00:00" endentry.Add "timeZone", "Asia/Tokyo" JsonObject.Add "end", endentry 'JSON Parse用 Dim Json Dim eventid As String 'HTTPリクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "POST", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Authorization", "Bearer " & access_token .send JsonConverter.ConvertToJson(JsonObject) Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 201 'レスポンスヘッダを取得 Debug.Print .getAllResponseHeaders() '返ってきたJSON文字列を取得 Set Json = JsonConverter.ParseJson(.ResponseText) 'イベントIDを取得する eventid = Json("id") 'イベントIDを書き込んでおく IniWrite "USER", "eventid", eventid '終了メッセージ MsgBox "イベントの登録が完了しました。" Case Else MsgBox "イベントの登録に失敗しました。" End Select End With End Function |
- Dictionaryを使って一つの連想配列をうまく作っていく必要があります。
- 大本のJsonObjectという連想配列に最終的に含めて１つのリクエストボディを作成し、リクエスト時にJsonConverter.ConvertToJsonにてJSON変換を行っています。
- エンドポイントに於いて、me/calendarsのみでリクエストした場合は、標準の予定表に書き込まれ、カレンダーIDを指定すると対象のカレンダーに書き込まれるようになっています。
- 他にも招待者の指定や、本文の指定（HTML表記可能）が可能になっています。
イベントIDは後で書き換えたり、削除したりする場合に必要なので、どこかに退避させておいて取っておきましょう。Plannerと違って更新時にはodata.etagなどの値は不要のようです。
図：イベントが登録された
カレンダーイベントを削除する
登録済みのカレンダーイベントを削除する場合には、対象のイベントのイベントIDが必要です。リストの取得や前述のカレンダー登録時にレスポンスで返ってくるので、これを控えておいて、リクエストを行います。こちらにマニュアルが掲載されています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
'カレンダーイベント削除 Public Function delCalEvent() 'リクエストエンドポイントを構築 Dim requrl As String Dim calid As String Dim eventid As String 'イベントIDの取得 eventid = IniRead("USER", "eventid", "") 'リクエストURLを構築 requrl = endpoint & "me/events/" & eventid 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'HTTPリクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "DELETE", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Authorization", "Bearer " & access_token .send Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 204 'レスポンスヘッダを取得 Debug.Print .getAllResponseHeaders() '終了メッセージ MsgBox "イベントの削除が完了しました。" Case Else MsgBox "イベントの削除に失敗しました。" End Select End With End Function |
- DELETEメソッドでリクエストを行います
- 基本的にはイベントIDのみでリクエストし削除を行えます。
- 成功レスポンスコードは204なので注意。
カレンダーイベントのリストを全取得する
対象のカレンダーに於けるイベントを取得します。各イベントの細かな情報を取得できる為、常にクリック時から１週間分の未完了のイベントを取得みたいな形で自分は取得させています。こちらにマニュアルが掲載されています。
ただし他のカレンダーイベントを取得する場合には事前にその人が次項の「カレンダーの共有設定」に於いて、所属組織内に対して公開をしていなければ、アクセスが拒否されますので要注意です（同時に他の人のカレンダーの場合、useridが必要になります）
今回は、レスポンスデータのうち、表題・開始日・終了日の３つだけをフィルタ指定して取得します。ただしこの手法は期間指定ができません。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
'カレンダーイベントを取得する Public Function getAllCalEventlist() 'リクエストエンドポイントを構築 Dim requrl As String Dim calid As String 'リクエストURLを構築 requrl = endpoint & "me/calendar/events?$select=subject,start,end" 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'HTTPリクエスト Dim tempstart As String Dim tempend As String Dim subject As String Dim eventrec As String With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Authorization", "Bearer " & access_token .send Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 200 '返ってきたJSON文字列を取得 Set Json = JsonConverter.ParseJson(.ResponseText) 'JSONの中でvalueの中身を取得する For Each records In Json("value") '開始日を取得する tempstart = records("start")("dateTime") '終了日を取得する tempend = records("end")("dateTime") '表題を取得する subject = records("subject") '取得データを表示する eventrec = "開始日：" & tempstart & vbCrLf & "終了日：" & tempend & vbCrLf & "表題：" & subject Debug.Print eventrec Next '終了メッセージ MsgBox "イベントのリストを取得しました。" Case Else MsgBox "イベントのリスト取得に失敗しました。" End Select End With End Function |
- リクエストURLにて、eventsの後に「?$select=subject,start,end」で取得項目を絞っています。
- レスポンスデータのvalueをfor eachで順次取得して最後にdebug.printにて表示させています。
カレンダーイベントを期間指定で取得する
前述の方法は日付で期間指定する手段が無い為、過去のも含めてずらーっと取得されてしまうのですが、calendarViewを用いると、URLリクエスト時に期間指定が可能であるため、通常はこちらを使ったほうが利便性は上です。
こちらにマニュアルが掲載されています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
'カレンダーイベントを期間指定で取得する Public Function getCalEventBetween() 'リクエストエンドポイントを構築 Dim requrl As String '期間指定 Dim start_datetime As String Dim end_datetime As String '11/1～11/30までの1か月間を指定する start_datetime = "2022-11-01T00:00:00" end_datetime = "2022-11-30T00:00:00" 'リクエストURLを構築 requrl = endpoint & "me/calendar/calendarView?startDateTime=" & start_datetime & "&endDateTime=" & end_datetime 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'JSON取得用 Dim Json '期間指定イベントリクエスト Dim tempstart As String Dim tempend As String Dim subject As String Dim eventrec As String With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Authorization", "Bearer " & access_token .send Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 200 '返ってきたJSON文字列を取得 Set Json = JsonConverter.ParseJson(.ResponseText) 'JSONの中でvalueの中身を取得する For Each records In Json("value") '開始日を取得する tempstart = records("start")("dateTime") '終了日を取得する tempend = records("end")("dateTime") '表題を取得する subject = records("subject") '取得データを表示する eventrec = "開始日：" & tempstart & vbCrLf & "終了日：" & tempend & vbCrLf & "表題：" & subject Debug.Print eventrec Next '終了メッセージ MsgBox "イベントのリストを取得しました。" Case Else MsgBox "イベントのリスト取得に失敗しました。" End Select End With End Function |
- startとendの2つの日付を指定し、URLのオプションとして追加します。
- 前述同様にレスポンスから、開始日、終了日、表題の３つを取得してDebug.Printで表示させています。
カレンダーの共有設定を変更する
他の人のカレンダーを取得したい場合、相手が所属組織内に対して対象のカレンダーを公開していなければ取得ができません。そこで、自分自身のカレンダーの共有設定をGraph APIから変更させて、公開したり非公開にしたりが可能です。
ただしこの設定変更をするためには現在のカレンダーにセットされてるpermissionidを取得してから、そのidを元に変更のリクエストを送る2段構えが必要になります。今回は所属してる組織（My Organization）を対象に行います。
なお、現在のroleがnoneならばlimitedRead, noneじゃなければnoneにするといった判定を入れています。roleはこちらに一覧があります。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
'カレンダーの共有設定を変更する Public Function calSettingChange() 'リクエストエンドポイントを構築 Dim requrl As String Dim calid As String 'リクエストURLを構築 requrl = endpoint & "me/calendar/calendar/calendarPermissions" 'Access Tokenの取得と失効チェック Dim tokenstatus As Boolean Dim ret As Variant Dim access_token As String tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック 'Tokenの状況に応じて処理を分岐 Select Case tokenstatus Case True '無事にTokenは生きてるので何もしない Case False 'refresh token使って新しいTokenを取得 ret = GetAccessToken(authcode, -1) '取得結果を判定 If ret = True Then '無事に取得できているのでスルーする Else '取得失敗 MsgBox "Access Tokenの取得に失敗しました。" Exit Function End If End Select 'Access Tokenを取得する access_token = IniRead("USER", "access_token", "") 'JSON取得用 Dim Json Dim permname As String Dim rolename As String Dim permid As String Dim changeflg As String Dim changename As String '現在のPermission取得のリクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Authorization", "Bearer " & access_token .send Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 200 '返ってきたJSON文字列を取得 Set Json = JsonConverter.ParseJson(.ResponseText) 'JSONの中でvalueの中身を取得する For Each records In Json("value") 'パーミッションIDを取得 permid = records("id") 'ロールを取得 rolename = records("role") 'パーミッションの名前を取得 permname = records("emailAddress")("name") 'パーミッション名がMy Organizationの場合は処理を実行 If permname = "My Organization" Then 'ロール名に応じてリクエストするchangeflgを変更 If rolename = "none" Then '限定公開とする changeflg = "limitedRead" changename = "タイトルと場所を閲覧可能" Else '非公開とする changeflg = "none" changename = "共有しない" End If 'リクエスト本文を構築 Dim JsonObject As Object Set JsonObject = New Dictionary JsonObject.Add "role", changeflg 'リクエストURLを構築 requrl = requrl & "/" & permid '権限変更リクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "PATCH", requrl, False '.setProxy 2, proxyuri .SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Authorization", "Bearer " & access_token .send JsonConverter.ConvertToJson(JsonObject) Debug.Print .Status '返ってきた値をもとにデータを処理 Select Case .Status Case 200 '終了メッセージ MsgBox "カレンダー権限を" & changename & "に変更しました。" Case Else MsgBox "カレンダー権限変更に失敗しました。" End Select End With 'ループ処理を終了 Exit For End If Next '終了メッセージ MsgBox "イベントのリストを取得しました。" Case Else MsgBox "カレンダー権限の取得に失敗しました。" End Select End With End Function |
- カレンダー共有が「共有しない」の場合には、「タイトルと場所を閲覧可能」なLimitedReadに変更します。
- permissionidを取得し、そのidを用いて再度更新のリクエストでroleを変更させています。リクエストメソッドはPATCHになるので注意。
- 個別の権限変更をする場合はpermnameの判定にユーザ名等の判定結果を入れて処理をします（今回は所属組織内の人なのでMy Organizationでフィルタ）
図：カレンダーへのアクセス許可
図：権限を変更する画面
