フォルダ参照権しかないOutlookの予定表を抽出する【Powershell,Excel VBA】
Outlookの予定表を抽出して会議室の使用実績を取りたいのですが、それには予定表の全詳細参照権が必要です。詳細参照権がない場合は予約調整のための空き情報参照の機能が使えます。
目次
Outlookの予定表抽出
自分自身の予定表抽出なら権限があるので、詳細データまで含めて抽出できます。
OutlookではScriptを使った時と人間の目で見る時と得られる情報が違うようで、フォルダ参照権限のある予定表でもscriptでは予定表をBind（掴む）しようとする時点でエラーになってしまいます。（正確にはLimited Details,日本語Outlookだと空き時間情報、件名、場所という権限の場合）しょうがないので色々調べていたら、予定調整の時にユーザーの空き情報を調べるGetUserAvailabilityというWeb APIを使うと開始・終了時間／空き情報とともに、権限のある場合Detailで件名と場所を取ることができるということがわかりました。これはOutlookの機能ではなくサーバー側のExchangeの機能です。
ExchangeサーバーのWeb API
Exchangeサーバーは2007の頃からWeb APIが実装されていて下記のURLに設定されます。
|
1 |
"https://[Exchangeサーバーアドレス]/ews/exchange.asmx" |
office365の場合は人によってアドレスが違うようで、Exchangeサービスに対してautoDiscoverメソッドを使ってURLを引くのが確実です。が、大概下記のアドレスで動きそうな情報がHitします。
|
1 |
"https://outlook.office365.com/EWS/Exchange.asmx" |
このアドレスはSOAPのAPIとして実装されていてhttpプロトコルを使ってxmlで書いたRequestを投げるとxmlのResponseが返ってくるというものです。最近（2019）はxmlを使うSOAPよりJSONを使ったREST APIの方が主流（というか書く方もその方が書きやすい）で、Exchange/Office365もREST APIにシフトしようとしていますがまだまだ技術情報の点ではSOAP APIの方が多いのが現状です。
なので、今回このSOAP API（Exchange Web Service,EWS）を使って抽出を試してみます。
EWSを使ってOutlookの予定表を抽出する
検索したところ、下記のMicrosoftの情報がみつかりました。
Office developer center:Exchange の EWS を使用して空き時間情報を取得する
これを読むと「会議の調整を自動化するためのAPI」ということでManaged APIを使ったC#のサンプルソースとXML Queryのサンプルが載っています。
Managed APIを使ってPowerShellで作ったサンプルソースがこちら。
-UseDefaultCredentialsオプションを使うと何故かautoDiscoverでコケる。
オンプレ環境なら動くかもしれません。
驚いたことにManaged APIのWebCredentialsが平文パスワードしか受け付けないらしいので、苦肉の策で入力されたパスワードを平文に戻してます。
|
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 |
param( #$ExchangeUser = "User01@tenantname.mail.onmicrosoft.com" ,# Office365に接続するログインIDとパスワードです $ExchangePassword , #Password直書きで気にならない方はここに記述 $CSV_File = "UserAvailability_by_powershell.csv", # ExportFileName。 $Mailboxes = @("User01@xxx.onmicrosft.com", "User02@xxx.onmicrosft.com", "User03@xxx.onmicrosft.com"), $EWS_URL = "https://outlook.office365.com/EWS/Exchange.asmx" #$EWS_URL = "https://[OnPremissExchange.server.local]/ews/exchange.asmx" # On premiss EWS URL ) #PowerShellにOffice365のExchange Web Services Managed APIをImport $EWS_DLL = "C:\Program Files\PackageManagement\NuGet\Packages\exchange.webservices.managed.api.2.2.1.2\lib\net35\Microsoft.Exchange.WebServices.dll" Import-Module $EWS_DLL if([String]::IsNullOrEmpty($ExchangePassword)) { $PSCredential = Get-Credential -Message "ExchangeOnlineのユーザ情報を入力してください。" -UserName $ExchangeUser $ExchangeCredential = New-Object Microsoft.Exchange.WebServices.Data.WebCredentials($PSCredential.UserName.ToString(),$PSCredential.GetNetworkCredential().password.ToString()) }else{ $ExchangeCredential = New-Object Microsoft.Exchange.WebServices.Data.WebCredentials($ExchangeUser,$ExchangePassword) } #$ExchangeCredential =New-Object Microsoft.Exchange.WebServices.Data.WebCredentials($user, $pass) $service = New-Object Microsoft.Exchange.WebServices.Data.ExchangeService $service.Credentials = $ExchangeCredential <# 2007以降のEXchangeは自己署名付き X509 証明書を使用して、EWS からの呼び出しを認証します。 ManagedAPIを使う場合、CallBack Method(Script Block)を指定しないとエラーを起こします。詳細は下記を参照してください。 https://docs.microsoft.com/ja-jp/exchange/client-developer/exchange-web-services/how-to-validate-a-server-certificate-for-the-ews-managed-api #> $service.AutodiscoverUrl($ExchangeUser, {$true}) <#AutoDiscoverしない場合は、バージョンも合わせないとエラーを起こします。 $ExchangeVersion = [Microsoft.Exchange.WebServices.Data.ExchangeVersion]::Exchange2010_SP1 $service = New-Object Microsoft.Exchange.WebServices.Data.ExchangeService($ExchangeVersion) $service.Url =$EWS_URL #> $Date= (get-date).AddMonths(-1) $StartDate = Get-Date ($Date.tostring("yyyy/MM/") +"21") $EndDate = $StartDate.AddMonths(1) $drDuration = new-object Microsoft.Exchange.WebServices.Data.TimeWindow($StartDate,$EndDate) $AvailabilityOptions = new-object Microsoft.Exchange.WebServices.Data.AvailabilityOptions $AvailabilityOptions.RequestedFreeBusyView = [Microsoft.Exchange.WebServices.Data.FreeBusyViewType]::DetailedMerged $listtype = ("System.Collections.Generic.List"+'`'+"1") -as "Type" $listtype = $listtype.MakeGenericType("Microsoft.Exchange.WebServices.Data.AttendeeInfo" -as "Type") $Attendeesbatch = [Activator]::CreateInstance($listtype) foreach ($Mailbox in $Mailboxes){ $Attendee = new-object Microsoft.Exchange.WebServices.Data.AttendeeInfo($Mailbox) $Attendeesbatch.add($Attendee) } #$Attendee = new-object Microsoft.Exchange.WebServices.Data.AttendeeInfo($Mailboxes[0]) #$Attendeesbatch.add($Attendee) $availresponse =$null #初期化 $CSV =@() $availresponse = $service.GetUserAvailability($Attendeesbatch,$drDuration,[Microsoft.Exchange.WebServices.Data.AvailabilityData]::FreeBusy,$AvailabilityOptions) For ($i=0 ;$i -lt $Attendeesbatch.Count ;$i++){ #foreach($avail in $availresponse.AttendeesAvailability){ $TargetUser = $Attendeesbatch[$i].SmtpAddress $avail = $availresponse.AttendeesAvailability[$i] foreach($cvtEnt in $avail.CalendarEvents){ $Row =""| Select User,StartTime,EndTime,Subject,Location $Row.User = $TargetUser $Row.StartTime = $cvtEnt.StartTime $Row.EndTime = $cvtEnt.EndTime $Row.Subject = $cvtEnt.Details.Subject $Row.Location = $cvtEnt.Details.Location "User : " + $TargetUser "Start : " + $cvtEnt.StartTime "End : " + $cvtEnt.EndTime "Subject : " + $cvtEnt.Details.Subject "Location : " + $cvtEnt.Details.Location "" $CSV += $Row } } $CSV| Export-Csv -Path .\$CSV_File -Encoding UTF8 -NoTypeInformation |
ExcelでOutlookの予定表を抽出する
オマケ:
偉大なるOutlook研究所様に上記の内容をOutlook VBAで実現するマクロが掲載されていました。
Outlookのマクロは昨今セキュリティが厳しいので、これをExcelに移植することにしました。で、試作してみたExcel VBAがこちら。
|
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 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
Public Sub ExportCalendar() On Error Resume Next Const CSV_FILE = “C:\log\Calendar.csv" ' エクスポートするファイル名を指定します。 '抽出する対象のサーバーを指定します。 Const EWSURL = "https://outlook.office365.com/EWS/Exchange.asmx" ’社内のサーバの場合は、outlookのアカウント設定でサーバを調べて書き換えてください。 ' Const EWSURL = "https://[社内のExchangeサーバーアドレス]/ews/exchange.asmx" Dim aAddressList ' エクスポートしたいユーザーのメールアドレスを指定します。 aAddressList = Array("user01@xxx.onmicrosoft.com", "user02@xxx.onmicrosoft.com", "user03@xxx.onmicrosoft.com", "user04@xxx.onmicrosoft.com") Dim dtDate As Date Dim dtStart As Date Dim dtEnd As Date Dim xmlResponse As Variant Dim arrFreeBusyResponse As Variant Dim i, j As Integer Dim lngRowCount As Long Dim objSheet As Object Dim strXmlQuery As Variant ' dtDate = DateAdd("ｍ", -1, Now) dtStart = DateSerial(Year(dtDate), Month(dtDate), 21) '前月の21日を作ります dtEnd = DateAdd("ｍ", 1, dtStart) Set xmlResponse = Nothing ' 空き時間情報を取得 GetUsersAvailability EWSURL, aAddressList, dtStart, dtEnd, xmlResponse If xmlResponse Is Nothing Then ' Close #1 MsgBox "取得に失敗しました" Exit Sub End If Open CSV_FILE For Output As #1 Print #1, """ユーザー"",""件名"",""場所"",""開始日時"",""終了日時"",""公開方法""" Set objSheet = ThisWorkbook.Sheets(1) 'シート全体をクリアする objSheet.Cells.Clear With objSheet .Cells(1, 1).Value = "アドレス" .Cells(1, 2).Value = "件名" .Cells(1, 3).Value = "場所" .Cells(1, 4).Value = "開始日時" .Cells(1, 5).Value = "終了日時" .Cells(1, 6).Value = "公開方法" lngRowCount = 2 ' 取得した空き時間 Set arrFreeBusyResponse = xmlResponse.DocumentElement.getElementsByTagName("FreeBusyResponse") For i = 0 To arrFreeBusyResponse.Length - 1 ' 取得が成功したか確認 If arrFreeBusyResponse(i).getElementsByTagName("ResponseMessage").Item(0).Attributes.getNamedItem("ResponseClass").Text = "Success" Then Dim objRec As Recipient Dim strUserName As String Dim arrCalEvents As Variant Dim calEvent As Variant Dim strStatus As String Dim strSubject As String Dim strLocation As String Dim dtCalStart As Date Dim dtCalEnd As Date ' Outlookを起動してメールアドレスからユーザー名を取得 'ここをコメントアウトしたままだとOutlookなしでExcel<->Exchangeの通信のみで処理がおわります。 'Dim appsOutlook As Application 'Dim objRec As Recipient 'Set appsOutlook = CreateObject("Outlook.Application") 'Set objRec = appsOutlook.Session.CreateRecipient(aAddressList(i)) 'objRec.Resolve 'strUserName = objRec.Name ' strUserName = aAddressList(i) ' 予定を一つずつ処理 Set arrCalEvents = arrFreeBusyResponse(i).getElementsByTagName("CalendarEvent") For j = 0 To arrCalEvents.Length - 1 Set calEvent = arrCalEvents(j) strStatus = GetValue(calEvent, "BusyType") strSubject = GetValue(calEvent, "Subject") strLocation = GetValue(calEvent, "Location") dtCalStart = GetDateValue(calEvent, "StartTime") dtCalEnd = GetDateValue(calEvent, "EndTime") ' While Not objAppt Is Nothing .Cells(lngRowCount, 1).Value = strUserName .Cells(lngRowCount, 2).Value = strSubject .Cells(lngRowCount, 3).Value = strLocation .Cells(lngRowCount, 4).Value = dtCalStart .Cells(lngRowCount, 5).Value = dtCalEnd .Cells(lngRowCount, 6).Value = strStatus ' 次のアイテム lngRowCount = lngRowCount + 1 ' Wend Print #1, """" & strUserName & """,""" & strSubject & """,""" & strLocation & """,""" _ & dtCalStart & """,""" & dtCalEnd & """,""" & strStatus & """,""" & objOrg & """,""" & objRes & """" Next End If Next End With Close #1 MsgBox "終了しました" End Sub ' Sub GetUsersAvailability(strUrl As String, aAddressList As Variant, dtStart As Date, dtEnd As Date, xmlResponse As Variant) Dim xmlHttp Dim strXmlQuery As Variant Dim strXml As String Dim strStart As String Dim strEnd As String Dim i As Integer ' EWS XML Queryをつくります Set xmlHttp = CreateObject("MSXML2.XMLHTTP") strXmlQuery = "<!--?xml version=""1.0"" encoding=""utf-8""?-->" & _ "<soap:envelope xmlns:xsi="" http:="" www.w3.org="" 2001="" xmlschema-instance"""="" &="" _="" "="" xmlns:xsd="" xmlschema"""="" xmlns:soap="" schemas.xmlsoap.org="" soap="" envelope="" """="" xmlns:t="" schemas.microsoft.com="" exchange="" services="" 2006="" types""="">" & _ "<soap:body>" & _ "<getuseravailabilityrequest xmlns="" http:="" schemas.microsoft.com="" exchange="" services="" 2006="" messages"""="" &="" _="" "="" xmlns:t="" types""="">" & _ "<t:timezone xmlns="" http:="" schemas.microsoft.com="" exchange="" services="" 2006="" types""="">" & _ "<bias>-540</bias>" & _ "<standardtime><bias>0</bias><time>00:00:00</time><dayorder>0</dayorder>" & _ "<month>0</month><dayofweek>Sunday</dayofweek></standardtime>" & _ "<daylighttime><bias>-60</bias><time>00:00:00</time><dayorder>0</dayorder>" & _ "<month>0</month><dayofweek>Sunday</dayofweek></daylighttime>" & _ "</t:timezone>" & _ "<mailboxdataarray>" ' 取得するAddressListを追加 For i = LBound(aAddressList) To UBound(aAddressList) strXmlQuery = strXmlQuery & _ "<t:mailboxdata><t:email><t:address>" & aAddressList(i) & "</t:address></t:email>" & _ "<t:attendeetype>Required</t:attendeetype><t:excludeconflicts>false</t:excludeconflicts>" & _ "</t:mailboxdata>" Next ' 取得する期間を設定 strStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss") strEnd = Format(dtEnd, "yyyy-mm-ddThh:nn:ss") strXmlQuery = strXmlQuery & _ "</mailboxdataarray>" & _ "<t:freebusyviewoptions>" & _ "<t:timewindow>" & _ "<t:starttime>" & strStart & "</t:starttime>" & _ "<t:endtime>" & strEnd & "</t:endtime>" & _ "</t:timewindow>" & _ "<t:mergedfreebusyintervalinminutes>60</t:mergedfreebusyintervalinminutes>" & _ "<t:requestedview>DetailedMerged</t:requestedview>" & _ "</t:freebusyviewoptions>" & _ "</getuseravailabilityrequest>" & _ "</soap:body>" & _ "</soap:envelope>" ' リクエスト送信 xmlHttp.Open "POST", strUrl, False xmlHttp.setRequestHeader "Content-Type", "text/xml" xmlHttp.Send strXmlQuery Debug.Print (strXmlQuery) If xmlHttp.Status = "200" Then Set xmlResponse = CreateObject("MSXML2.DOMDocument") If xmlResponse.LoadXML(xmlHttp.responseText) Then ' OK ならここで終了 Exit Sub End If End If ' エラーなら Nothing を設定 Set xmlResponse = Nothing End Sub ' Function GetValue(xmlNode, strName) On Error Resume Next Dim arrNodes Set arrNodes = xmlNode.getElementsByTagName(strName) If arrNodes.Length = 0 Then GetValue = "" Else GetValue = arrNodes(0).Text End If End Function ' Function GetDateValue(xmlNode, strName) On Error Resume Next Dim arrNodes Dim strDate Set arrNodes = xmlNode.getElementsByTagName(strName) If arrNodes.Length = 0 Then GetDateValue = "" Else strDate = arrNodes(0).Text strDate = Replace(strDate, "-", "/") strDate = Replace(strDate, "T", " ") GetDateValue = CDate(strDate) End If End Function |
Excelマクロの説明
先月の21日から今月の20日までの予約を抽出して、CSVとExcelのsheet1に転記する、というものです。
日付は適当に書き換えてみてください。
“フォルダ参照権しかないOutlookの予定表を抽出する【Powershell,Excel VBA】” に対して1件のコメントがあります。