「空き時間情報、件名、場所」の権限がある他のユーザーの予定を CSV にエクスポートするマクロ


コメントにて以下のご要望をいただきました。


いつも参考にさせていただいております。
現在、こちらの[Exchange 環境の複数ユーザーの予定を CSV にエクスポートするマクロ]の記事を参考にExchange環境のスケジュールを取得しようと考えております。

こちらのExchange環境では、参照者のフォルダへのアクセス権限が「件名」「場所」「空き時間情報」のみとなっているためか、開始時間や終了時間をキーにFindしようとしても失敗してしまいます。

そこで、件名をキーにすべてのスケジュールを抽出したいのですがどのようにすればよろしいか教えていただいてもよろしいでしょうか。
Findではできないかと思い、Restrictを使用したりしたのですが出力形式が違うためうまく動作しません。

よろしくお願いいたします。


「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロの記事で説明している通り、Exchange 環境でフォルダーのアクセス権限が「空き時間情報、件名、場所」となっている場合、EWS でアクセスする必要があります。
こちらの記事のマクロでは HTML 形式にして表示していますが、CSV 形式でファイルにエクスポートするよう編集しました。
マクロは以下の通りです。
EWS_URL には Exchange サーバーの EWS の URL を指定します。
なお、EWS では件名を検索条件とすることはできないため、開始日時と終了日時を検索条件に指定しています。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ExportOthersCalendarFB()
    On Error Resume Next
    Const CSV_FILE_NAME = "c:\temp\thismonth.csv" ' エクスポートするファイル名を指定してください。
    Const EWS_URL = "http://casserver.example.com/ews/exchange.asmx" ' EWS の URL を指定します。
    Dim aMailboxes
    ' エクスポートしたいユーザーのメールアドレスを指定します。
    aMailboxes = Array("user1@example.com", "user2@example.com", "user3@example.com")
    Dim dtExport As Date
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim xmlDoc As Variant
    Dim arrFBResps As Variant
    Dim i, j As Integer
    '
    dtExport = Now ' 来月の予定をエクスポートする場合は Now の代わりに DateAdd("m",1,Now) を使用します。
    ' 月単位ではなく任意の単位にする場合は以下の記述を変更します。
    dtStart = CDate(Year(dtExport) & "/" & Month(dtExport) & "/1 00:00")
    dtEnd = DateAdd("m", 1, dtStart)
    ' ヘッダー部分の出力
    Open CSV_FILE_NAME For Output As #1
    Print #1, """ユーザー"",""件名"",""場所"",""開始日時"",""終了日時"",""公開方法"""
    ' 空き時間情報を取得
    Set xmlDoc = Nothing
    GetUsersAvailability EWS_URL, aMailboxes, dtStart, dtEnd, xmlDoc
    If xmlDoc Is Nothing Then
        Close #1
        Exit Sub
    End If
    ' 取得した空き時間
    Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
    For i = 0 To arrFBResps.Length - 1
        ' 取得が成功したか確認
        If arrFBResps(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
            ' メールアドレスからユーザー名を取得
            Set objRec = Session.CreateRecipient(aMailboxes(i))
            objRec.Resolve
            strUserName = objRec.Name
            ' 予定を一つずつ処理
            Set arrCalEvents = arrFBResps(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")
                Print #1, """" & strUserName & """,""" & strSubject & """,""" & strLocation & """,""" _
                    & dtCalStart & """,""" & dtCalEnd & """,""" & strStatus & """"
            Next
        End If
    Next
    Close #1
End Sub
'
Sub GetUsersAvailability(strUrl As String, aMailboxes As Variant, dtStart As Date, dtEnd As Date, xmlDoc As Variant)
    Dim xmlHttp
    Dim strXmlData As Variant
    Dim strStart As String
    Dim strEnd As String
    Dim i As Integer
    ' EWS リクエスト生成
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    strXmlData = "<?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>"
    ' 取得するメールボックスを追加
    For i = LBound(aMailboxes) To UBound(aMailboxes)
        strXmlData = strXmlData & _
            "<t:MailboxData><t:Email><t:Address>" & aMailboxes(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")
    strXmlData = strXmlData & _
        "</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 ' , strDom & "\" & strUser, strPass
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.Send strXmlData
    If xmlHttp.Status = "200" Then
        Set xmlDoc = CreateObject("MSXML2.DOMDocument")
        If xmlDoc.LoadXML(xmlHttp.responseText) Then
            ' OK ならここで終了
            Exit Sub
        End If
    End If
    ' エラーなら Nothing を設定
    Set xmlDoc = 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

マクロの登録方法やメニューへの追加について

広告

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中