【outlook】１か月分の予定表を書き出すＶＢＡ

質問

こんにちは。
Outlook2010で１か月分の予定をエクセルに書き出したいと考えています。
以下のＶＢＡを見つけることはできましたが、１か月分の予定を書き出すＶＢＡに書き換えができませんでした。
どのように修正すべきかご教示いただければと存じます。
よろしくお願いします。

----------------------------------------------
Sub Excel週間予定()

'期間指定
Dim dateFrom As Date
Dim dateTo As Date
'初期値
dateFrom = Date
'入力ダイアログを表示
dateFrom = InputBox("開始日を入力してください。", "週間予定", dateFrom)
'7日間
dateTo = DateAdd("d", 7, dateFrom)
'MsgBox dateFrom
'MsgBox dateTo

'予定表モジュールを取得
Dim calmod As CalendarModule
Set calmod = Application.ActiveExplorer.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
'MsgBox calmod

'Excelを取得
Dim Excelapp As Object
Set Excelapp = CreateObject("Excel.Application")

'表示
Excelapp.Visible = True

'ブックを作成
Excelapp.Workbooks.Add

'ヘッダを準備
Excelapp.Range("A1:G1") = Array("予定表", "件名", "場所", "開始時刻", "終了時刻", "終日イベント")

'2行目から
Dim row As Integer
row = 2

'すべての予定表グループに対して
Dim grp As NavigationGroup
For Each grp In calmod.NavigationGroups
'MsgBox grp

'すべての予定表に対して
Dim fol As NavigationFolder
For Each fol In grp.NavigationFolders
'MsgBox fol

'チェックされている予定表のみ
If fol.IsSelected Then
'MsgBox fol

'予定の絞り込み
Dim col As Items
Set col = fol.Folder.Items
col.Sort "[Start]"
col.IncludeRecurrences = True
Dim appointment
Set appointment = col.Find("[Start] < """ & Format(dateTo, "yyyy/mm/dd") & """ AND [End] >= """ & Format(dateFrom, "yyyy/mm/dd") & """")

'見つかった予定に対して
While Not appointment Is Nothing

Excelapp.Cells(row, 1).Value = fol.DisplayName
Excelapp.Cells(row, 2).Value = appointment.Subject
Excelapp.Cells(row, 3).Value = appointment.Location
Excelapp.Cells(row, 4).Value = appointment.Start
Excelapp.Cells(row, 5).Value = appointment.End
Excelapp.Cells(row, 6).Value = appointment.AllDayEvent
row = row + 1

Set appointment = col.FindNext
Wend

End If

Next

Next

'MsgBox "end"

End Sub

回答No.1

HohoPapa

指定日から３１日以後までという条件でよければ

dateFrom = InputBox("開始日を入力してください。", "週間予定", dateFrom)
'7日間
dateTo = DateAdd("d", 7, dateFrom)
'MsgBox dateFrom
'MsgBox dateTo

を

dateFrom = InputBox("開始日を入力してください。", "向こう３１日間予定", dateFrom)
'31日間
dateTo = DateAdd("d", 31, dateFrom)
MsgBox dateFrom
MsgBox dateTo

と書き換えればいいと思います。

なお、３１日後まで（つまり、スタート日を含め３２日間）とする必要があれば、

Set appointment = col.Find("[Start] < """ & Format(dateTo, "yyyy/mm/dd") & """ AND [End] >= """ & Format(dateFrom, "yyyy/mm/dd") & """")

は、

Set appointment = col.Find("[Start] < """ & Format(dateTo + 1, "yyyy/mm/dd") & """ AND [End] >= """ & Format(dateFrom, "yyyy/mm/dd") & """")

とする必要があるものと思います。