「空き時間情報、件名、場所」の権限がある他のユーザーの予定を行ごとに色分けして一括で表示するマクロ


「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロのコメントにて以下のご要望をいただきました。


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



ご認識の通り CSS を使うことにはなるのですが、CSS の指定もマクロの中で行う必要があります。
交互に色分けとのことですが、ユーザーごとに色分けするようにしてみました。
マクロは以下の通りです。
ユーザーの数が色の数より多い場合は色が繰り返されることになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ShowGroupScheduleTodayColor()
    '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", "user4@example.com")  ' 表示したいユーザーのメールアドレスを指定します。
    Const COLOR_MAX = 4 ' 色の最大数を指定します。
    Dim aBGColors
    aBGColors = Array("#ddddff", "#ddffdd", "#ffdddd", "#ffffbb")  ' 背景色を HTML のカラーコードで指定します。
    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' style='background-color:" & _
            aBGColors(i Mod COLOR_MAX) & ";'>"
        Print #1, "<a href=""mailto:" & objRec.Address & """>" & objRec.Name & "</a></div>"
        strHtml = strHtml & "<div class='tf' style='background-color:" & _
            aBGColors(i Mod COLOR_MAX) & ";'>"
        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

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

「空き時間情報、件名、場所」の権限がある他のユーザーの予定を行ごとに色分けして一括で表示するマクロ」への1件のフィードバック

  1. ご対応頂きありがとうございました。
    表示していた数が多かった為に、非常に見やすくなりました!

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中