Outlookの予定表を抽出して会議室の使用実績を取りたいのですが、それには予定表の全詳細参照権が必要です。詳細参照権がない場合は予約調整のための空き情報参照の機能が使えます。

Outlookの予定表抽出

自分自身の予定表抽出なら権限があるので、詳細データまで含めて抽出できます。

OutlookではScriptを使った時と人間の目で見る時と得られる情報が違うようで、フォルダ参照権限のある予定表でもscriptでは予定表をBind（掴む）しようとする時点でエラーになってしまいます。（正確にはLimited Details,日本語Outlookだと空き時間情報、件名、場所という権限の場合）しょうがないので色々調べていたら、予定調整の時にユーザーの空き情報を調べるGetUserAvailabilityというWeb APIを使うと開始・終了時間／空き情報とともに、権限のある場合Detailで件名と場所を取ることができるということがわかりました。これはOutlookの機能ではなくサーバー側のExchangeの機能です。

ExchangeサーバーのWeb API

Exchangeサーバーは2007の頃からWeb APIが実装されていて下記のURLに設定されます。

"https://[Exchangeサーバーアドレス]/ews/exchange.asmx"

office365の場合は人によってアドレスが違うようで、Exchangeサービスに対してautoDiscoverメソッドを使ってURLを引くのが確実です。が、大概下記のアドレスで動きそうな情報がHitします。

"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が平文パスワードしか受け付けないらしいので、苦肉の策で入力されたパスワードを平文に戻してます。

param(
#$ExchangeUser = "User01@fujitsu.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がこちら。

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 = "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "-540" & _
        "000:00:000" & _
        "0Sunday" & _
        "-6000:00:000" & _
        "0Sunday" & _
        "" & _
        ""
    ' 取得するAddressListを追加
    For i = LBound(aAddressList) To UBound(aAddressList)
        strXmlQuery = strXmlQuery & _
            "" & aAddressList(i) & "" & _
            "Requiredfalse" & _
            ""
    Next
    ' 取得する期間を設定
    strStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss")
    strEnd = Format(dtEnd, "yyyy-mm-ddThh:nn:ss")
    strXmlQuery = strXmlQuery & _
        "" & _
        "" & _
        "" & _
        "" & strStart & "" & _
        "" & strEnd & "" & _
        "" & _
        "60" & _
        "DetailedMerged" & _
        "" & _
        "" & _
        "" & _
        ""
    ' リクエスト送信
    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に転記する、というものです。

日付は適当に書き換えてみてください。