「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロ


ほかのユーザーの予定を一括で表示するマクロのコメントにて以下のご要望をいただきました。


[全詳細情報] の読み取り権限が必要とのことですが、残念ながら私の会社では「件名・場所」までの設定しか認められていません。使用している情報が「件名・場所」の設定範囲だけなのにとても残念です。何か方法はないのでしょうか?



「空き時間情報、件名、場所」の権限がある場合、Outlook は Exchange サーバーの可用性サービスを使用して件名や場所を予定表に表示できます。
しかし、残念ながら Outlook オブジェクト モデルでは、可用性サービスを使用して件名や場所を取得するメソッドなどが用意されていません。
そこで、Exchange サーバーの Exchange Web Service を直接呼び出すマクロを作成してみました。
マクロは以下の通りです。
EWS_URL には Exchange サーバーの EWS の URL を指定します。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ShowGroupScheduleToday()
    On Error Resume Next
    Const HTMLFILE = "c:\temp\gs.htm" ' 作成する HTML ファイルのフルパスを指定します。
    Const STARTTIME = 8 ' 業務の開始時間を指定します。この例では 8 時としています。
    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 strToday As String
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim strHtml As String
    Dim i, j As Integer
    Dim objWsh As Object
    Dim iRange
    Dim arrFBResps
    '
    strToday = FormatDateTime(Now, vbShortDate)
    dtStart = CDate(strToday & " " & STARTTIME & ":00")
    dtEnd = DateAdd("d", 1, strToday)
    iRange = (24 - STARTTIME) * 60
    ' 固定部分の出力
    Open HTMLFILE For Output As #1
    Print #1, "<html><head><META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=shift-jis"">"
    Print #1, "<title>" & strToday & "の予定</title><style>"
    Print #1, "a {color:black;text-decoration:none;}"
    Print #1, ".b1 {position:absolute;width:100px;font-size:10px;border:1px solid black;}"
    Print #1, ".nm {position:relative;width:98px;height:14px;overflow:hidden;border-bottom: 1px dotted silver;}"
    Print #1, ".b2 {position:absolute;width:800px;left:110px;font-size:10px;overflow:scroll;border:1px solid black;}"
    Print #1, ".tf {position:relative;width:" & iRange & "px;height:14px;border-bottom: 1px dotted silver;}"
    Print #1, ".tb {position:absolute;width:60px;height:14px;border-right: 1px solid black;}"
    Print #1, ".bsTentative {position:absolute;height:12px;overflow:hidden;border: 1px solid silver;background-color:silver;}"
    Print #1, ".bsBusy {position:absolute;height:12px;overflow:hidden;border: 1px solid #5f5fe8;background-color:#ccccff;}"
    Print #1, ".bsOOF {position:absolute;height:12px;overflow:hidden;border: 1px solid #700070;background-color:#ffccff;}"
    Print #1, "</style></head>"
    Print #1, "<body><h1>" & strToday & "の予定</h1>"
    Print #1, "<div style='position:relative;font-size:10px;height:14px;'>"
    Print #1, "<div class='bsBusy' style='left:700px;width:50px;'>予定あり</div>"
    Print #1, "<div class='bsTentative' style='left:760px;width:50px;'>仮の予定</div>"
    Print #1, "<div class='bsOOF' style='left:820px;width:50px;'>外出中</div>"
    Print #1, "</div>"
    Print #1, "<div class='b1'>"
    Print #1, "<div class='nm'>グループ メンバ</div>"
    ' 空き時間情報を取得
    Set xmlDoc = Nothing
    GetUsersAvailability EWS_URL, aMailboxes, dtStart, dtEnd, xmlDoc
    If xmlDoc Is Nothing Then
        Exit Sub
    End If
    ' 取得した空き時間
    strHtml = ""
    Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
    For i = 0 To arrFBResps.Length - 1
        ' メールアドレスからユーザー名を取得
        Set objRec = Session.CreateRecipient(aMailboxes(i))
        objRec.Resolve
        Print #1, "<div class='nm'>"
        Print #1, "<a href=""mailto:" & objRec.Address & """>" & objRec.Name & "</a></div>"
        strHtml = strHtml & "<div class='tf'>"
        For t = STARTTIME To 23
            strHtml = strHtml & "<div class='tb' style='left:" & ((t - STARTTIME) * 60) & "px;'></div>"
        Next
        ' 取得が成功したか確認
        If arrFBResps(i).getElementsByTagName("ResponseMessage").Item(0).Attributes.getNamedItem("ResponseClass").Text = "Success" Then
            Dim arrCalEvents
            Dim calEvent
            Dim strStatus
            Dim strSubject
            Dim strLocation
            Dim dtCalStart
            Dim dtCalEnd
            Dim iStart As Integer
            Dim iEnd As Integer
            ' 予定を一つずつ処理
            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")
                ' 予定の公開方法が空き時間でない場合のみ出力
                If strStatus <> "Free" Then
                    dtCalStart = GetDateValue(calEvent, "StartTime")
                    iStart = DateDiff("n", dtStart, dtCalStart)
                    If iStart < 0 Then iStart = 0
                    dtCalEnd = GetDateValue(calEvent, "EndTime")
                    iEnd = DateDiff("n", dtStart, dtCalEnd)
                    If iEnd > 1440 Then iEnd = 1440
                    strHtml = strHtml & "<div class='bs" & strStatus & _
                        "' style='left:" & iStart & "px;width:" & (iEnd - iStart) & "px;'>" & _
                        "<a href=""#"" title=""" & FormatDateTime(dtCalStart, vbShortTime) & _
                        " - " & FormatDateTime(dtCalEnd, vbShortTime) & _
                        " " & strSubject & " " & strLocation & """>" & strSubject & "</a></div>"
                End If
            Next
        Else
            ' 取得が失敗したらエラーメッセージを表示
            strHtml = strHtml & "<div>取得できませんでした。</div>"
        End If
        strHtml = strHtml & "</div>"
    Next
    Print #1, "</div>"
    Print #1, "<div class='b2'><div class='tf'>"
    For t = STARTTIME To 23
        Print #1, "<div style='position:absolute;left:" & ((t - STARTTIME) * 60) & "px;'>" & t & ":00</div>"
    Next
    Print #1, "</div>" & strHtml & "</div>"
    Close #1
    Set objWsh = CreateObject("Wscript.Shell")
    objWsh.Run HTMLFILE
End Sub
'
Sub GetUsersAvailability(strUrl, aMailboxes, dtStart, dtEnd, xmlDoc)
    Dim xmlHttp
    Dim strXmlData
    Dim strStart
    Dim strEnd
    ' 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

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

「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロ」への5件のフィードバック

  1. 本件をリクエストした者です。

    リクエスト後、予定(空き時間情報、件名、場所)を登録するDB(SQLServer)を
    設けて、Outlook起動時およびDBに登録された予定を照会するVBA実行時に、
    ユーザー自身の予定を登録VBAを作成しました。予定の鮮度は少し悪くなりますが、
    ユーザーの予定をDBに集めておいて、照会時にはDBを検索するという仕組みです。
    利用を開始して3ヶ月程経過しましたが、一番の問題は作成したVBAを登録してくれない
    ユーザーが、まだまだ残っているということです。(想定はしていましたが...)

    今回、示して頂いたVBAを参考に、近い将来のバージョンアップに反映出来たらと思います。
    ありがとうございました。

  2. このマクロ使用させて頂きます。
    初歩的な事ですみませんが、予定が複数ある場合、行を交互に色分けする場合はどうすればいいでしょうか?
    HTMLは詳しくわかりませんが、CSSを使って処理するしかないのでしょうか?
    もしご存知の方がいましたらご教示ください。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中