Outlookの予定表を削除するExcelVBAコード

Outlookの予定表を削除する手順は難しい
Outlookの予定削除では全部の予定を順番に調べる
Outlookの予定を削除するExcelVBAコード

Outlookの予定表を削除する手順は難しい

前回Outlookの予定表を登録するExcelVBAコードを紹介しました。

これは私の職場のように、課やグループ内ではExcelで外出や休み・内勤などの予定を把握しているものの、社内の他の部署に対してはOutlookの予定表でスケジュールを共有している場合、Excelで管理している予定を手間なくOutlookに登録することを想定して作成しました。

予定表登録は月に1回の登録を想定していたので、月内であまり予定が変更ない場合特に問題ないのですが、私の所属部署は月の中での予定変更がかなりあります。
変更が生じた場合にOutlookの予定表登録を行っても以前の予定が削除されずに残った状態となり、どんどん古い予定が積み重なってしまう問題が生じていました。

今回はOutlook上の予定表を常に最新の状態に保つため、Outlookの予定表を削除するExcelVBAコードを考えましたので紹介します。

Outlookの予定削除では全部の予定を順番に調べる

Outlookの予定は予定表のアイテムとして登録されています。
予定表のアイテム自体の中で日付ごとの順序などは特にないようで、期間での絞り込みなどはできず、すべての予定を調べる必要があります。

よって今回は条件分岐を用いて対象の予定を削除するExcelVBAコードを考えました。

Outlookの予定を削除するExcelVBAコード

予定表を登録した際のExcelシートが残っている場合、その情報を元に該当する予定を削除するExcelVBAコードは下記の通りです。

Sub Outlook予定表削除()

Dim i As Long, x As Long
Dim oApp ’As Outlook.Application OutlookのApplication オブジェクトを入れる
Dim myNameSpace ’As Outlook.NameSpace
Dim myFolder ’As Outlook.Folder フォルダー指定

Set oApp = CreateObject(“Outlook.Application”)
Set myNameSpace = oApp.GetNamespace(“MAPI”)
Set myFolder = myNameSpace.GetDefaultFolder(9) ’規定のフォルダー olFolderCalendar=9 指定

Dim aITEM ’As Outlook.AppointmentItem

Dim タイトル As String, 場所 As String, 内容 As String
Dim 開始日 As Date, 開始時間 As Date, 終了日 As Date, 終了時間 As Date, 終日 As Boolean

i = 2
Do Until Cells(i, 1).Value = “”

タイトル = Cells(i, 1)
場所 = Cells(i, 2)
内容 = Cells(i, 3)
開始日 = Cells(i, 4)

If Cells(i, 8) <> “” Then ’終日のイベントかどうか判定
終日 = True
開始時間 = “0:00:00”
終了日 = 開始日 + 1 ’終日イベントの終了日は開始日の翌日に設定
終了時間 = “0:00:00”
Else
終日 = False
’開始時刻記載有無の条件分岐
If Cells(i, 5).Text = “” Then
開始時間 = “0:00:00”
Else
開始時間 = Cells(i, 5)
End If

’終了日記載有無の条件分岐
If Cells(i, 6).Text = “” Then
終了日 = 開始日
Else
終了日 = Cells(i, 6)
End If

’終了時間記載有無の条件分岐
If Cells(i, 7).Text = “” Then
終了時間 = “0:00:00”
Else
終了時間 = Cells(i, 7)
End If

End If

For Each aITEM In myFolder.Items
If aITEM.AllDayEvent = True Then ’終日の場合
If aITEM.Start = 開始日 And aITEM.End = 終了日 And _
aITEM.Subject = タイトル And aITEM.Location = 場所 Then
aITEM.Delete
Exit For
End If
Else ’終日ではない場合
If aITEM.Start = 開始日 + 開始時間 And aITEM.End = 終了日 + 終了時間 And _
aITEM.Subject = タイトル And aITEM.Location = 場所 Then
aITEM.Delete
Exit For
End If
End If

Next aITEM
i = i + 1
Loop

Set aITEM = Nothing
Set myFolder = Nothing
Set myNameSpace = Nothing
Set oApp = Nothing

End Sub

このVBAコードは該当する予定の絞り込みを日付・時間・タイトル・場所でかなり細かく行っているため、もともと登録した情報がExcelのシート上に残っている場合、誤って別の予定を削除してしまう可能性がないのが大きなメリットになります。

しかし、予定を記載したExcelのシートが残っていない場合、シートを作り直さなければならないデメリットがあります。
この問題を解決するために下記のようなコードも考えてみました。

Sub Outlook予定表削除2()

Dim i As Long, x As Long
Dim oApp ’As Outlook.Application OutlookのApplication オブジェクトを入れる
Dim myNameSpace ’As Outlook.NameSpace
Dim myFolder ’As Outlook.Folder フォルダー指定

Set oApp = CreateObject(“Outlook.Application”)
Set myNameSpace = oApp.GetNamespace(“MAPI”)
Set myFolder = myNameSpace.GetDefaultFolder(9) ’規定のフォルダー olFolderCalendar=9 指定

myFolder.Display
oApp.ActiveWindow.WindowState = 2 ’olNormalWindow=2 (olMaximized=0,olMinimized=1)

Dim aITEM ’As Outlook.AppointmentItem

i = 2
Do Until Cells(i, 1).Value = “”

For Each aITEM In myFolder.Items
’「開始日」と「本文の最初の4文字」で判定
If Int(aITEM.Start) = Cells(i, 1) And Left(aITEM.Body, 4) = “自動入力” Then
aITEM.Delete
End If
Next aITEM
i = i + 1
Loop

Set myFolder = Nothing
Set myNameSpace = Nothing
Set oApp = Nothing

End Sub

こちらは開始日と本文（内容）でのみの判定をする仕様となっています。

Excelのシート上のA列に削除したい予定表の日付を記入しておき実行することで、該当の日付で本文（内容）が「自動入力」から始まる予定表を削除します。