【Excel VBA】Outlookの予定表をExcelの一覧表に出力する（CSVエクスポートなし）

Outlookに登録してある予定表のデータをExcelに一覧形式で取り込みたいのです。
以前、VBAを使ってメールの件名一覧を作ったことがあったので、カレンダーもなんとかなるだろうという発想でした。
ちなみに、メール操作のコードは過去のものとして、どこかに消えていってしまいました。きっと偉い人に接収されたのだと思いますｗ

昔のことを思い出しながら、可能なことだとは分かっていながら、とりあえずの対策ということでOutlookマクロでCSVを吐き出させていました。
ここのところでまとまった時間があったような気がしたので、改めて調べながらマクロを書きました。
今度はなくさないように備忘録を残します！ｗ

それにしても、Excel VBAは便利ですね。
その分危険なこともあるということは肝に銘じておきましょう。

Outlookオブジェクトを呼ぶ

オブジェクトを呼び、名前空間を呼び、フォルダーを開いて、予定の配列を引っ張り出す、みたいなことです。
あちこちのサイトを見比べて、イケてるコードをいただいてきました。

Outlookマクロも参考にしています。オブジェクトの定義がExcelとは異なるのです。

ぶっちゃけ、詳細は分からないところもあります。
魔法の言葉ということで使っていますｗ
以前もそうだったので、大丈夫だと思います。毎月お世話になっていました。そしてこれからもお世話になるのです。

書いたコード

書いたコードのデフォルメは以下のとおりです。
実際には、シートオブジェクトを指定して、取得対象の日付範囲は動的に変わるようにしました。

このコードの実行には、参照設定が必要です。
VBAの画面の「ツール」→「参照設定」から、「Microsoft Outlook 14.0 Object Library」をオンにします。

サンプルコード

Sub getOutlookCalenderItems()
    ' Outlookオブジェクト
    Dim objOLApp ' As Outlook.Application
    Set objOLApp = CreateObject("Outlook.Application")
    ' Outlook名前空間
    Dim nmsOLApp ' Outlook.NameSpace
    Set nmsOLApp = objOLApp.GetNamespace("MAPI")
    ' 予定表フォルダー
    Dim fldCalendar ' Outlook.Folder
    Set fldCalendar = nmsOLApp.GetDefaultFolder(olFolderCalendar)
    ' 予定
    Dim colAppts ' As Items
    Set colAppts = fldCalendar.Items
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True
    ' 個々の予定
    Dim objAppt ' As AppointmentItem
    Set objAppt = colAppts.Find("[Start] < ""2017/7/1"" AND [End] >= ""2017/6/1""") ' ★
    ' -- 転記
    Dim lngRowCount As Long
    Dim objSheet As Object
    Set objSheet = ThisWorkbook.Sheets(1)
    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
        While Not objAppt Is Nothing
            .Cells(lngRowCount, 1).Value = FormatDateTime(objAppt.Start, vbShortDate)
            .Cells(lngRowCount, 2).Value = FormatDateTime(objAppt.Start, vbShortTime)
            .Cells(lngRowCount, 3).Value = FormatDateTime(objAppt.End, vbShortTime)
            .Cells(lngRowCount, 4).Value = objAppt.Subject
            .Cells(lngRowCount, 5).Value = objAppt.Location
            .Cells(lngRowCount, 6).Value = objAppt.Body
            ' 次のアイテム
            Set objAppt = colAppts.FindNext
            lngRowCount = lngRowCount + 1
        Wend
    End With
    '
    Set objAppt = Nothing
    Set colAppts = Nothing
    Set fldCalendar = Nothing
    Set nmsOLApp = Nothing
    Set objOLApp = Nothing
End Sub

時刻まで指定

上記のサンプルコード内の「★」マーク部分で、時刻まで指定する書き方は以下のとおりです。
時刻の前に半角スペースを入れるだけです。

    Set objAppt = colAppts.Find("[Start] < ""2017/7/1 5:00"" AND [End] >= ""2017/6/1 5:00""")

範囲を変数化

上記サンプルコード内の「★」マーク部分で、変数を利用した書き方は以下のとおりです。
上述のとおり、ダブルクォーテーションのエスケープがやっかいです。

    Set objAppt = colAppts.Find("[Start] < """ & 変数1 & """ AND [End] >= """ & 変数2 & """")

実際のところは、毎月範囲が変わりますので、こちらで運用しております。

日付時刻で範囲指定が可能

AppointmentItem の Find で、開始と終了を文字列指定できます。
実際に書いたコードでは、日付を動的に代入する文字列型変数をアンパサンドで繋ぎました。
その際は、ダブルクォーテーションのエスケープ方法にご注意を。

範囲指定をしないと、登録してある予定を最初から全件出力することになります。
場合によっては相当な数になって激しいループに陥るので注意が必要です。

細かい設定方法などは、個別にMSDNで調べられます。

これで、Outlook側で稼働させていたマクロは不要になりました。
Excelに一本化できて便利です♪