VBA で Outlook 予定表から日報メールを作成する

Public Sub CreateDailyMail()
    Dim l_calendar As Outlook.Folder
    Set l_calendar = Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)

    Dim l_appointments As Outlook.Items
    Set l_appointments = l_calendar.Items

    Set l_appointments = l_appointments.Restrict( _
        "(([Start] = '2015/12/24 0:00') And ([AllDayEvent] = True)) Or " & _
        "(([Start] <= '2015/12/24 0:00') And ([End] < '2015/12/25 0:00'))")

    Dim l_appointmentList As String
    Dim l_appointment As Outlook.AppointmentItem

    For Each l_appointment In l_appointments
        l_appointmentList = l_appointmentList & l_appointment.Subject & vbCrLf
    Next

    ' テンプレート ファイルのパスの部分は、環境に応じて設定してください。
    Dim l_mail As Outlook.MailItem
    Set l_mail = Application.CreateItemFromTemplate("C:\...\DailyReport.oft")

    l_mail.Body = Replace(l_mail.Body, "<<Appointments>>", l_appointmentList)

    l_mail.Display
End Sub

Dim l_calendar As Outlook.Folder
Set l_calendar = Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)

Dim l_appointments As Outlook.Items
Set l_appointments = l_calendar.Items

Set l_appointments = l_appointments.Restrict( _
    "(([Start] = '2015/12/24 0:00') And ([AllDayEvent] = True)) Or " & _
    "(([Start] >= '2015/12/24 0:00') And ([End] < '2015/12/25 0:00'))")

Dim l_mail As Outlook.MailItem
Set l_mail = Application.CreateItemFromTemplate("C:\...\DailyReport.oft")

Dim l_appointmentList As String
Dim l_appointment As Outlook.AppointmentItem

For Each l_appointment In l_appointments
    l_appointmentList = l_appointmentList & l_appointment.Subject & vbCrLf
Next

l_mail.Body = Replace(l_mail.Body, "<<Appointments>>", l_appointmentList)

l_mail.Display

([Start] >= '2015/12/24 0:00') And ([End] < '2015/12/25 0:00')

([Start] = '2015/12/24 0:00') And ([AllDayEvent] = True)

(([Start] >= '2015/12/24 0:00') And ([End] < '2015/12/25 0:00')) Or 
(([Start] = '2015/12/24 0:00') And ([AllDayEvent] = True))

[Start] >= '2015/12/24 0:00'

'2015/12/24 0:00' <= [Start]

Public Sub CreateDailyMail2()
    Dim l_today As Date
    l_today = Date
    
    Dim l_tomorrow As Date
    l_tomorrow = GetNextDate(l_today)
    
    ' テンプレートからメールを新規作成します。
    ' (この時点では、まだメールは画面には表示されません。)
    ' テンプレート ファイルのパスの部分は、環境に応じて設定してください。
    Dim l_mail As Outlook.MailItem
    Set l_mail = Application.CreateItemFromTemplate("C:\...\DailyReport2.oft")
    
    l_mail.Subject = Replace(l_mail.Subject, "<<Date>>", Format(l_today, "yyyy/mm/dd"))
    l_mail.Body = Replace(l_mail.Body, "<<Date>>", Format(l_today, "yyyy/mm/dd"))
    
    Dim l_appointments As Outlook.Items
    
    ' 本日の予定 (会議以外) を検索し、メールの本文に埋め込みます。
    Set l_appointments = FindAppointments(l_today, OlMeetingStatus.olNonMeeting)
    l_mail.Body = Replace(l_mail.Body, "<<Todays Appointments>>", CreateApplintmentList(l_appointments))
    
    ' 本日の予定 (会議) を検索し、メールの本文に埋め込みます。
    Set l_appointments = FindAppointments(l_today, OlMeetingStatus.olMeeting)
    l_mail.Body = Replace(l_mail.Body, "<<Todays Meetings>>", CreateApplintmentList(l_appointments))
    
    ' 明日の予定 (会議以外) を検索し、メールの本文に埋め込みます。
    Set l_appointments = FindAppointments(l_tomorrow, OlMeetingStatus.olNonMeeting)
    l_mail.Body = Replace(l_mail.Body, "<<Tomorrows Appointments>>", CreateApplintmentList(l_appointments))
    
    ' 明日の予定 (会議) を検索し、メールの本文に埋め込みます。
    Set l_appointments = FindAppointments(l_tomorrow, OlMeetingStatus.olMeeting)
    l_mail.Body = Replace(l_mail.Body, "<<Tomorrows Meetings>>", CreateApplintmentList(l_appointments))
    
    ' メールを表示します。
    l_mail.Display
End Sub

' 予定を検索します。
' <params>
'   p_date
'       検索対象の日付。
'   p_meetingStatus
'       検索対象の会議の状態。会議の場合は olMeeting を、会議以外の場合は olNonMeeting を指定します。
' <returns>
'   p_date および p_meetingStatus で指定された条件に一致する、0 個以上の予定。
Private Function FindAppointments( _
    ByVal p_date As Date, ByVal p_meetingStatus As Outlook.OlMeetingStatus) As Outlook.Items

    ' 予定表を取得します。
    Dim l_calendar As Outlook.Folder
    Set l_calendar = Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
    
    ' 予定表に登録されているすべての予定を取得します。
    Dim l_appointments As Outlook.Items
    Set l_appointments = l_calendar.Items
    
    ' 定期的な予定を検索に含めます。
    l_appointments.IncludeRecurrences = True
    l_appointments.Sort "[Start]"

    ' 終日の AppointmentItem を抽出するフィルターを作成します。
    Dim l_filterDate As String
    l_filterDate = "([Start] = " & FormatFilterDateTime(p_date) & ") And ([AllDayEvent] = True)"

    ' 開始時刻、終了時刻の指定がある AppointmentItem を抽出するフィルターを作成します。
    Dim l_filterDateTime As String
    l_filterDateTime = _
        "([Start] >= " & FormatFilterDateTime(p_date) & ")" & _
        " And ([End] < " & FormatFilterDateTime(GetNextDate(p_date)) & ")"
    
    ' 予定が会議か、会議以外かを区別するフィルターを作成します。
    Dim l_filterMeetingStatus As String
    l_filterMeetingStatus = "[MeetingStatus] = " & p_meetingStatus
    
    ' フィルターを組み立てます。
    Dim l_filter As String
    l_filter = "((" & l_filterDate & ") Or (" & l_filterDateTime & ")) And (" & l_filterMeetingStatus & ")"
    
    ' 予定表に登録されているすべての予定に対して、フィルターを適用します。
    Set l_appointments = l_appointments.Restrict(l_filter)
    
    Set FindAppointments = l_appointments
End Function

' 0 個以上の予定の内容が改行で結合された文字列を作成します。
' <params>
'   p_appointments
'       予定のコレクション。
' <returns>
'   p_appointmentItems の各項目の内容が改行で結合された文字列。
Private Function CreateApplintmentList(ByVal p_appointments As Items) As String
    Dim l_count As Integer
    l_count = GetItemCount(p_appointments)
 
    Dim l_appointmentList As String
    Dim i As Integer

    For i = 1 To l_count
        l_appointmentList = l_appointmentList & "・" & p_appointments(i).Subject
        
        If i < l_count Then
            l_appointmentList = l_appointmentList & vbCrLf
        End If
    Next
    
    CreateApplintmentList = l_appointmentList
End Function

' Outlook.Items オブジェクト内の項目の数を取得します。
' <params>
'   p_items
'       項目の数を取得する対象のコレクション。
' <returns>
'   p_items に含まれる項目の数。
' <remarks>
'   コレクション内に定期的な予定が存在する場合は、Items.Count の値は Long 型の最大値になるようです。
'   (たとえば、実際の予定は 3 件でも、Items.Count の値は 2,147,483,647 になっています。)
'   そのため、実際の項目数を調べるためのこのメソッドを用意しました。
Private Function GetItemCount(ByVal p_items As Outlook.Items) As Long
    Dim l_item As Object
    
    Dim l_count As Integer
    l_count = 0
 
    ' p_items の実際の項目数を調べます。
    For Each l_item In p_items
        l_count = l_count + 1
    Next
    
    GetItemCount = l_count
End Function

' フィルターに適した日時の書式を適用します。
' たとえば、指定した日時が #2015/5/1 5:06:07# であれば、2015/05/01 5:06" という文字列になります。
' <params>
'   p_date
'       フィルターに適した日時の書式を適用する対象の日時。
' <returns>
'   p_date に書式が設定された文字列。
Private Function FormatFilterDateTime(ByVal p_date As Date) As String
    FormatFilterDateTime = "'" & Format(p_date, "yyyy/mm/dd h:nn") & "'"
End Function

' 指定した日の翌日の日付を取得します。
' <params>
'   p_date
'       翌日の日付を取得する対象の日時。
' <returns>
'   p_date の翌日の日付。
Private Function GetNextDate(ByVal p_date As Date) As Date
    GetNextDate = DateAdd("d", 1, p_date)
End Function