Sub 先月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) - 1, 1), DateSerial(Year(Now), Month(Now), 0))
End Sub
Sub 当月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) - 0, 1), DateSerial(Year(Date), Month(Date) + 1, 0))
End Sub
Sub 翌月のOutlook予定表を取り込む()
Call Outlookの予定表を取り込む(DateSerial(Year(Now), Month(Now) + 1, 1), DateSerial(Year(Date), Month(Date) + 2, 0))
End Sub
Sub Outlookの予定表を取り込む(strDayStart As Date, strDayEnd As Date)
'Outlook用の定義
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Folder
Dim olConItems As Outlook.Items
Dim olItem As AppointmentItem
Dim oPattern
'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount As Long
'スクリーンの更新は行われません。
Application.ScreenUpdating = False
'Excelのブックとワークシートのオブジェクトを設定します。
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'書き込み先のセルを指定します。また1行目にタイトルを記述します。
With wsSheet
.Range("A3").CurrentRegion.Clear
.Cells(2, 1).Value = "件名"
.Cells(2, 2).Value = "場所"
.Cells(2, 3).Value = "開始日時"
.Cells(2, 4).Value = "終了日時"
.Cells(2, 5).Value = "予定の本文"
.Cells(2, 6).Value = "予約者"
.Cells(2, 7).Value = "必須出席者"
.Cells(2, 8).Value = "任意出席者"
.Cells(2, 9).Value = "EntryID"
.Cells(2, 10).Value = "IsRecurring"
With .Range("A1:Z1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
wsSheet.Activate
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
Set olConItems = olFolder.Items
'取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
lnContactCount = 3
Dim objAppt As AppointmentItem
Dim strStart As String
Dim strEnd As String
strStart = Format(strDayStart, "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
strEnd = Format(strDayEnd, "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
strEnd = DateAdd("d", 1, strEnd) ' 1日追加
'開始日でソート
olConItems.Sort "[Start]"
'定期的な予定を含む※Falseであると定期的な予定は含まない
olConItems.IncludeRecurrences = True
'Findメソッドで期間指定して抽出するスケジュールを絞り込む
Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")
While TypeName(olItem) = "AppointmentItem"
'Findで検索すると期間範囲外の余計なものまでヒットしてしまうので、再度フィルタリングする
If olItem.Start >= strStart And olItem.End < strEnd Then
With olItem
Cells(lnContactCount, 1).Value = .Subject
Cells(lnContactCount, 2).Value = .Location
Cells(lnContactCount, 3).Value = .Start
Cells(lnContactCount, 4).Value = .End
Cells(lnContactCount, 5).Value = .Body
Cells(lnContactCount, 6).Value = .Organizer
Cells(lnContactCount, 7).Value = .RequiredAttendees
Cells(lnContactCount, 8).Value = .OptionalAttendees
Cells(lnContactCount, 9).Value = .EntryID
Cells(lnContactCount, 10).Value = .IsRecurring
End With
Set oPattern = Nothing
lnContactCount = lnContactCount + 1
End If
Set olItem = olConItems.FindNext
Wend
'Null out the variables.
Set olItem = Nothing
Set olConItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox strDayStart & "から" & strDayEnd & "のOutlook予定表の取り込みが完了しました！", vbInformation
End Sub
コメントを残す