Outlookのリモート会議予定を自動的に家族に共有して事故を防ぐ

1月 26, 2021

職場のOutlook予定表に登録されたリモートワーク会議の予定を、機微情報を削除した状態で日々Googleカレンダーに転記して家族に共有することで、リモート会議で機微な情報を話している状況で不意に家族が部屋に入ってくる、という事故を最小限の労力で回避しているというお話です。

リモートワークのよくある課題

自宅でリモートワークをしていると、リモート会議で機微な情報について話している最中に家族が自室に入って来そうになる…こんな状況を経験した人は多いと思います。特に、複数が頻繁にリモート会議しながら自宅で仕事を進めている場合、どうしても仕事場を部屋ごと分ける必要があるため、誰かがLDKを占有するような状況が発生しがちです。この場合、セキュリティを維持するために仕事中のLDK立ち入りを禁止すると、家族は昼間に水すら飲めなくなってしまいます。

解決の方向性：あらかじめ会議予定を共有する

根本的に解決するなら、広い家に引っ越して個別に仕事部屋を作るのが一番なのですが、なかなかそう簡単にはいきません。今の環境でも実行できる解決策としては、あらかじめリモート会議の予定を家族に共有しておき、その時間は絶対に部屋に立ち入らないようにお願いする、程度が現実的です。

障害：日々の予定を都度確認し、伝達するのは非常に面倒

部屋への立ち入りで若干揉めた後しばらくは、LDKを使っている私が日々リモート会議の予定を手動でGoogleカレンダーに登録し、ここを見て立ち入り可否を判断するようお願いしていました。しかし、毎日翌日以降のリモート会議の予定を確認して手動で1つ1つ登録するのは本当に面倒です。また、当日になって急に入ってくる予定も多く、その場合は私が入力を忘れてしまったり、妻の方で見てくれなかったりします。

そもそもLDKを使っている私だけがなぜこんな面倒なことを毎日しなくてはいけないのか…それなら私も寝室がいい。しかし、妻は寝室をどうしても譲ろうとしません…。てかそのディスプレイもデスクもライトも私のだし、ネットワーク整備したのも私なんだが…。

障害：既存のツールによる自動化は望み薄

こうなると登録を自動化したくなるわけですが、既存の同期ツールではなかなか実現が難しいです。なぜなら、対象は全ての予定ではなくリモート会議のみで、かつ機微な情報が含まれる可能性があるため、詳細はおろかタイトルも転記したくないからです。もしかしたら既存ツールにも同期対象を細かく設定でき、転記ルールも独自で指定できるものがあるのかもしれませんが、私は見つけることはできませんでした。

また、Outlook<->Googleカレンダーの同期ツールはこれまでにも出来ては消えを繰り返してきた歴史があります。私も過去何度か評判の良いものを使ってみましたが、しばらくするとOutlookやGoogleカレンダーの仕様変更でうまく同期できなくなったり、同期に失敗してどちらかのカレンダーを壊してしまうようなことが起きて長期間使えたものはありませんでした。

Outlookマクロを自作して自動化

というわけで、いっそOutlookマクロを自作して自動化することにしました。自作が一番長期間使えないんじゃ…というツッコミもあるかもしれませんが、現段階で望みどおり動作するものがないので仕方が有りません。

動作の概要

Outlook起動時に、今日から14日後までの予定のうち、場所にZoom・Teams、内容にZoomと入っているものについて、Googleカレンダーに「リモート会議」というタイトルで予定を作成します。家族への通知はGoogleカレンダー自身の通知の仕組みに加えて、家族のLINEグループに対してIFTTT->LINE Notifierで通知し、確実に届くようにしています。

今回は大人同士なのでLINEで通知するに留めていますが、情報は既にあるので、必要があればもっとわかりやすい立入禁止表示もできます。スマートホームに絡めて、ドアに近づいたのをモーションセンサーが感知したら注意の音声を流すとか、立入禁止の間はランプを自動で赤色にする、なんて面白そうです。

Raspberry pi＋Homebridge＋IRKitで自宅をスマート化し、Google Home/Android/HomeKitから操作する

早期リタイアに向けた資産運用、各種社会制度の利用、節約、家計管理、ホームオートメーション等

Outlook VBAマクロ

もしかしたら使いたい人がいるかもしれないので、VBAマクロをそのまま記載しておきます。VBAの言語仕様は大して知らずに書いていますし、エラー処理も省略していますのでそのあたりはご了承ください。変更が必要な項目は冒頭に定数としてまとめてありますので、自分向けに情報を適当に書き換えて使ってください。あ、起動時に自動実行するためには、Application_StartupサブルーチンをThisOutlookSessionモジュールに含める必要があるのでご注意を。

Google Calendar APIの認証情報を取得するための手順は、以下のブログを見ていただいた方が良いかと思います。Google Calendar APIを呼び出す部分はこのブログを参考にしており、アクセス部分のコードもかなり流用させてもらっています。

あえてVBAで書くことでGmail APIを完全に理解する - Qiita

CAUTION この記事の目的はタイトルの通りであり、 Excel VBAからGmail APIでメール送信を行うことを推奨するものではありません。なぜなら今回使用する250行を超えるコードはOutlookを使えば ...

スクリプト

'Google Calendar API 認証情報'
Const CLIENT_ID As String = "786205282-mgi2538ek8l799qng3u3tbch6gr718v0.apps.googleusercontent.com"
Const CLIENT_SECRET As String = "LYCLDh2cdRP9CUgLw_Qu-aPJ"
Const AUTH_URI As String = "https://accounts.google.com/o/oauth2/auth"
Const TOKEN_URI As String = "https://oauth2.googleapis.com/token"
Const REDIRECT_URI As String = "urn:ietf:wg:oauth:2.0:oob"
Const AUTHORIZATION_CODE = "4/2AHAouMvOp9awlEIhOgMMqQQAu8r_RUAR7eoK0dMCY4lP0wjMlEkRm4"
Const REFRESH_TOKEN As String = "1//0e7DzSCothJQqCgYIARAAGA4SNwF-L9IrmrRr4djqULvjNcnZT8-QqZL4YwaDILtEDxWqrgrbTy8_celYY5DOQLWH60iYa7IHtls"

'反映先カレンダーのID'
Const CALENDAR_ID As String = "nse85fs2eo0eoh5gpm0jous8p4@group.calendar.google.com"
'反映する予定のタイトル'
Const CALENDAR_TITLE As String = "リモート会議"
'何日先まで反映するか'
Const NEXT_DAYS As Integer = 14

Const CALENDAR_URI As String = "https://www.googleapis.com/calendar/v3/calendars/" & CALENDAR_ID & "/events"

'Outlook起動時に自動実行'
Private Sub Application_Startup()
  Call UpdateWebMeeting
End Sub

'Outlook予定からリモート会議を取得'
Sub UpdateWebMeeting()
 Dim httpReq As XMLHTTP60
 Set httpReq = New XMLHTTP60
 
 Dim myNameSpace As Outlook.NameSpace
 Dim myAppointments As Outlook.Items
 Dim currentAppointment As Outlook.AppointmentItem
 Set myNameSpace = Application.GetNamespace("MAPI")
 
 Dim tdystart As Date
 Dim tdyend As Date
 tdystart = VBA.Format(Now, "Short Date")
 tdyend = VBA.Format(Now + NEXT_DAYS, "Short Date")
 
 Debug.Print (tdystart)
 Debug.Print (tdyend)
 
 Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
 
 myAppointments.Sort "[Start]"
 myAppointments.IncludeRecurrences = True
 
 Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")

 While TypeName(currentAppointment) <> "Nothing"
   If LCase(currentAppointment.Location) Like "*zoom*" Or LCase(currentAppointment.Body) Like "*zoom*" Or LCase(currentAppointment.Location) Like "*teams*" Or LCase(currentAppointment.Body) Like "*teams*" Then
     UpdateAppointment currentAppointment.start, currentAppointment.End
   End If
   Set currentAppointment = myAppointments.FindNext
 Wend

End Sub

'Google Calendar APIで既存の予定を確認、なければ追加する'
Public Sub UpdateAppointment(startTime As Date, endTime As Date)
  Dim param As Object
  Set param = CreateObject("Scripting.Dictionary")
  
    'リフレッシュトークンをアクセストークンに交換'
    Dim accessToken As String
    With param
        .Add "refresh_token", REFRESH_TOKEN
        .Add "client_id", CLIENT_ID
        .Add "client_secret", CLIENT_SECRET
        .Add "redirect_uri", REDIRECT_URI
        .Add "grant_type", "refresh_token"
    End With
    accessToken = KickAPI("POST", TOKEN_URI, param, "QueryString").item("access_token")
    param.RemoveAll
  
  Dim startTimeStr As String
  Dim endTimeStr As String
  startTimeStr = Format(startTime, "yyyy-mm-ddThh%3Amm%3A00%2B09%3A00")
  endTimeStr = Format(endTime, "yyyy-mm-ddThh%3Amm%3A00%2B09%3A00")
  
  Debug.Print (startTimeStr)
  Debug.Print (endTimeStr)
  
  With param
      .Add "q", EncodeUrl(CALENDAR_TITLE)
      .Add "timeMax", endTimeStr
      .Add "timeMin", startTimeStr
  End With
  Debug.Print (ConvertToQueryString(param))
      
  Dim response As Object
  Set response = KickAPI("GET", CALENDAR_URI & "?" & ConvertToQueryString(param), param, "QueryString", accessToken)
  param.RemoveAll
  
  'Itemsが存在し、かつ開始終了時刻が一致するItemが存在する → スキップ'
  'それ以外 → 登録'
  startTimeStr = Format(startTime, "yyyy-mm-ddThh:mm:00+09:00")
  endTimeStr = Format(endTime, "yyyy-mm-ddThh:mm:00+09:00")
  
  Dim item As Variant
  Dim startTimeOfTheItem As String
  Dim endTimeOfTheItem As String
  Dim exist As Boolean
  For Each item In response("items")
    startTimeOfTheItem = item("start")("dateTime")
    endTimeOfTheItem = item("end")("dateTime")
    If startTimeStr = startTimeOfTheItem And endTimeStr = endTimeOfTheItem Then
      exist = True
    End If
  Next
  
  Dim startParam As Object
  Set startParam = CreateObject("Scripting.Dictionary")
  startParam.Add "dateTime", Format(startTime, "yyyy-mm-ddThh:mm:00+09:00")
  
  Dim endParam As Object
  Set endParam = CreateObject("Scripting.Dictionary")
  endParam.Add "dateTime", Format(endTime, "yyyy-mm-ddThh:mm:00+09:00")
  
  If Not exist Then
    '登録'
     With param
      .Add "summary", CALENDAR_TITLE
      .Add "location", "Zoom/Teams"
      .Add "start", startParam
      .Add "end", endParam
     End With

     Debug.Print (ConvertToJson(param))

     Set response = KickAPI("POST", CALENDAR_URI, param, "JSON", accessToken)
  End If

End Sub

Public Sub GetAuthorizationURI()

    Dim param As Object
    Set param = CreateObject("Scripting.Dictionary")
    With param
        .Add "response_type", "code"
        .Add "client_id", CLIENT_ID
        .Add "redirect_uri", REDIRECT_URI
        '.Add "scope", "https://www.googleapis.com/auth/calendar"'
        'エラーが出たらURLエンコードしたこっち'
        .Add "scope", "https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fcalendar"
    End With

    Debug.Print AUTH_URI & "?" & ConvertToQueryString(param)

End Sub

Public Sub GetRefreshToken()
    Dim param As Object
    Set param = CreateObject("Scripting.Dictionary")
    With param
        .Add "code", AUTHORIZATION_CODE
        .Add "client_id", CLIENT_ID
        .Add "client_secret", CLIENT_SECRET
        .Add "redirect_uri", REDIRECT_URI
        .Add "grant_type", "authorization_code"
        .Add "access_type", "offline"
    End With
    
    'Debug.Print (ConvertToJson(param))'
    Debug.Print KickAPI("POST", TOKEN_URI, param).item("refresh_token")
End Sub

Private Function KickAPI( _
    ByVal method As String, _
    ByVal tgtAPI As String, _
    Optional ByVal param As Object, _
    Optional ByVal paramType As String, _
    Optional ByVal accessToken As String) As Object

    With CreateObject("MSXML2.XMLHTTP")
        .Open method, tgtAPI, False
        'アクセストークンがあればヘッダーに記述'
        If accessToken <> "" Then _
            .setRequestHeader "Authorization", "Bearer " & accessToken
        'パラメータを指定した形に変換してリクエスト送信'
        Select Case paramType
        Case "JSON"
            .setRequestHeader "Content-Type", "application/json; charset=UTF-8"
            .Send (ConvertToJson(param))
        Case "QueryString", ""
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .Send (ConvertToQueryString(param))
        End Select
        '不具合が出た場合は↓をアンコメントしてレスポンスを確認'
        Debug.Print .responseText
        'JSONが返されたらパース'
        Set KickAPI = IIf(.responseText = "", _
            CreateObject("Scripting.Dictionary"), _
            ParseJson(.responseText))
    End With

End Function

Private Function ConvertToQueryString( _
    ByVal dic As Object) As String

    If dic Is Nothing Then Exit Function
    '受け取った連想配列のkeyとvalueを繋げてクエリ文字列を作る'
    Dim key As Variant
    For Each key In dic.Keys
        ConvertToQueryString = ConvertToQueryString & "&" & key & "=" & dic.item(key)
    Next

End Function

Function EncodeUrl(str As String)
    Dim xlApp: Set xlApp = CreateObject("Excel.application")
    EncodeUrl = xlApp.WorksheetFunction.EncodeUrl(str)
    Set xlApp = Nothing
End Function

※Google Code Prettifyで表示するため、コメントの末尾にはすべてセミコロンを付加しています。Debug等の実行可能文をコメント解除する際は、末尾を消さないと動かないので気をつけてください。

VBAでOutlookの予定を検索するのがこんなに面倒だとは知りませんでした。今回は性能を犠牲にして手を抜いています。また、Google Cloud APIをライブラリを使わずに叩いたのも初めてでしたが、こっちもかなり面倒くさいですね…。VBAでやるのが間違っているのでしょうが。

このブログを検索

早期リタイアに備えて暮らす