仕事と予定の重複アイテムを削除するマクロ

メッセージで以下のようなご質問をいただきました。

---

ActiveSyncのエラーなどにより、Outlookの「仕事」や予定の項目が重複することがしばしばあります。
作成日時以外の内容が同一の項目などをすっきり削除するマクロは可能でしょうか。

---

どこまで同じ値のプロパティを持ったアイテムを重複とみなすかという点が問題になるかとは思いますが、以下のプロパティが同じ場合に重複とみなす、という基準でマクロを作ってみました。

仕事アイテム

件名、本文、期限、分類項目が同じものを重複とみなす

予定アイテム

件名、本文、開始日時、終了日時が同じものを重複とみなす

マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Public Sub RemoveDuplicateTaskAndAppointments()
     Dim iCurFolder As Integer
     Dim fldCurrent As Object ' Folder
     Dim colItems As Items
     Dim i As Integer
     Dim j As Integer
     Dim bMatch As Boolean
     Dim objItem As Object
'
     iCurFolder = olFolderTasks ' 仕事フォルダから処理を開始
     While iCurFolder = olFolderTasks Or iCurFolder = olFolderCalendar
         Set fldCurrent = Session.GetDefaultFolder(iCurFolder)
         Set colItems = fldCurrent.Items
         colItems.Sort "[件名]" ' 件名で並び替え
         For i = colItems.Count To 2 Step -1
             For j = i - 1 To 1 Step -1
                 If colItems(i).Subject = colItems(j).Subject Then ' 件名が同じなら他のプロパティの比較
                     bMatch = False
                     Select Case iCurFolder
                         Case olFolderTasks ' 仕事アイテムは本文、期限、分類項目を比較
                             If colItems(i).Body = colItems(j).Body And _
                              colItems(i).DueDate = colItems(j).DueDate And _
                              colItems(i).Categories = colItems(j).Categories Then
                                 bMatch = True
                             End If
                         Case olFolderCalendar ' 予定アイテムは本文、開始日時、終了日時を比較
                             If colItems(i).Body = colItems(j).Body And _
                              colItems(i).Start = colItems(j).Start And _
                              colItems(i).End = colItems(j).End Then
                                 bMatch = True
                             End If
                     End Select
                     If bMatch Then ' 一致したら最終更新日時が古いアイテムを削除
                         If colItems(i).LastModificationTime >= colItems(j).LastModificationTime Then
                             Set objItem = colItems(j)
                         Else
                             Set objItem = colItems(i)
                         End If
                         objItem.Delete
                         i = i - 1
                         j = i
                     End If
                 Else
                     Exit For ' 件名が一致しなければ次のアイテム
                 End If
             Next
         Next
         If iCurFolder = olFolderTasks Then
             iCurFolder = olFolderCalendar
         Else
             iCurFolder = -1
         End If
     Wend
End Sub

マクロの登録方法やメニューへの追加について