2019年7月22日 / 最終更新日 : 2019年10月12日 sito IT

フォルダ参照権しかない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に設定されます。

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

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

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

"https://outlook.office365.com/EWS/Exchange.asmx"

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

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

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研究所

Outlook を徹底活用する方法を研究するサイトです。

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 = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<soap:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""" & _
        " xmlns:xsd=""http://www.w3.org/2001/XMLSchema""" & _
        " xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<soap:Body>" & _
        "<GetUserAvailabilityRequest xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/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

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

193

194

195

196

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 & """"

End If

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=""http://www.w3.org/2001/XMLSchema""" & _

" xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/""" & _

" xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _

"<soap:Body>" & _

"<GetUserAvailabilityRequest xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages""" & _

" xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/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>"

' 取得する期間を設定

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

' エラーなら 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に転記する、というものです。

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

カテゴリー: IT

タグ: EWS Excel Exchange Managed API Outlook Outlook Calendar VBA 予定表抽出

コメントを残すコメントをキャンセル

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。

Outlookの予定表抽出

ExchangeサーバーのWeb API

EWSを使ってOutlookの予定表を抽出する

ExcelでOutlookの予定表を抽出する

Excelマクロの説明

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル