Sub Outlookの予定表を変更()
'ファイルの検索
Dim fName As String
fName = Application.GetOpenFilename(FileFilter:="Excelブック,*.xls*", MultiSelect:=False)
If fName = "False" Then
MsgBox "キャンセルしました。"
Exit Sub '終了
End If
'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 olItemBefor As AppointmentItem
Dim checkFlg As Long
'重複チェックフラグ初期値設定
checkFlg = 0
'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount As Long
Dim i As Integer
'抽出期間の定義
Dim strStart As String
Dim strEnd As String
Dim intKikan As Integer
'対象予定表の抽出期間を月単位で指定します。
'※抽出期間が短いと予定アイテムのチェックができず登録できない場合がありますので注意してください｡
'intKikan = 12 '抽出期間を12か月にしています。
'抽出期間をフォーム入力へ変更
intKikan① = InputBox(prompt:="変更開始日をyyyy/mm/ddで入力してください。", Title:="期間設定")
intKikan② = InputBox(prompt:="変更終了日をyyyy/mm/ddで入力してください。", Title:="期間設定")
'strStart = Format(DateAdd("m", -intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
'strEnd = Format(DateAdd("m", intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
strStart = Format(intKikan①, "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
strEnd = Format(intKikan②, "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
'スクリーンの更新は行われません。
Application.ScreenUpdating = False
'Excelのブックとワークシートのオブジェクトを設定します。
Set wbBook = Workbooks.Open(fName)
Set wsSheet = wbBook.Worksheets("予定表リスト")
wsSheet.Activate
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
Set olConItems = olFolder.Items
'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
'取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
lnContactCount = 2
Dim rc As Integer
rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbYes Then
'予定表一覧の件数分繰り返す。
For i = lnContactCount To Cells(1, 1).End(xlDown).Row
Set olItem = olApp.CreateItem(olAppointmentItem)
'重複チェック＆更新処理
For Each olItemBefor In olConItems
If TypeName(olItemBefor) = "AppointmentItem" Then
'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
If olItemBefor.EntryID = Cells(i, 9) Then
'比較用に一時的に作成
With olItem
.Subject = Cells(i, 1)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
End With
'重複フラグ1をセット
checkFlg = 1
'登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
'※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
Else
With olItemBefor
.Subject = Cells(i, 1)
.Location = Cells(i, 2)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
.Body = Cells(i, 5)
.RequiredAttendees = Cells(i, 6)
.OptionalAttendees = Cells(i, 7)
.Save
End With
End If
'Null out the variables.
Set olItem = Nothing
End If
End If
Next
If checkFlg <> 1 Then
'ExcelI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録
With olItem
.Subject = Cells(i, 1)
.Location = Cells(i, 2)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
.Body = Cells(i, 5)
.RequiredAttendees = Cells(i, 6)
.OptionalAttendees = Cells(i, 7)
.Save
End With
'ExcelI列へ発行されたEntryIDを書き込み
Cells(i, 9) = olItem.EntryID
End If
'重複フラグリセット
checkFlg = 0
Next
Else
MsgBox "処理を中断します"
Exit Sub
End If
'Null out the variables.
Set olItem = Nothing
Set olApp = Nothing
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox "Outlook予定表の登録が完了しました！", vbInformation
End Sub
内容が重複する予定アイテムが実際には存在しなかったとしても、例えば CSV ファイル側の[開始日]が異なる日付に変更されれば、当然 Outlook 側の元の予定アイテムの日付とは一致しないため紐付けることが出来ません。
逆に Outlook 側で元の予定アイテムの[開始日]が変更された場合も同様です。
Q&A
ベストアンサー
