Удаление дубликатов писем в Outlook

Для удаления используем VBA-скрипт в самом Outlook.

Данный скрипт удаляет дубликаты писем не только в выбранной папке Outlook, но и во всех её подпапка, на основе темы, отправителя и даты получения письма.

Шаги для использования VBA-скрипта:

1. Откройте редактор VBA в Outlook:

   • Нажмите Alt + F11, чтобы открыть редактор VBA.

   • В левом окне (Project Explorer) найдите ThisOutlookSession (или создайте новый модуль).

2. Вставьте следующий код:

Sub RemoveDuplicateEmailsInFolderAndSubfolders()
   Dim objFolder As Outlook.Folder
   Dim objDictionary As Object

   ' Выберите корневую папку, в которой нужно удалить дубликаты
   Set objFolder = Application.Session.PickFolder

   ' Проверка, выбрана ли папка
   If objFolder Is Nothing Then
      MsgBox "Папка не выбрана. Операция отменена.", vbExclamation
      Exit Sub
   End If

   ' Создаем словарь для хранения уникальных ключей
   Set objDictionary = CreateObject("Scripting.Dictionary")

   ' Обрабатываем выбранную папку и все её подпапки
   ProcessFolder objFolder, objDictionary

   ' Очищаем память
   Set objFolder = Nothing
   Set objDictionary = Nothing

   MsgBox "Дубликаты удалены во всех папках и подпапках!", vbInformation
   End Sub

   ' Рекурсивная функция для обработки папки и её подпапок
   Sub ProcessFolder(objFolder As Outlook.Folder, objDictionary As Object)
   Dim objItem As Object
   Dim strKey As String
   Dim i As Long

   ' Обрабатываем все элементы в текущей папке
   For i = objFolder.Items.Count To 1 Step -1
      Set objItem = objFolder.Items(i)

      ' Проверяем, является ли элемент письмом
      If objItem.Class = olMail Then
         ' Создаем уникальный ключ на основе темы, отправителя и даты получения
          strKey = objItem.Subject & "|" & objItem.SenderEmailAddress & "|" & Format(objItem.ReceivedTime, "yyyy-mm-dd hh:nn:ss")

          ' Если ключ уже существует, удаляем письмо
          If objDictionary.Exists(strKey) Then
             objItem.Delete
          Else
             ' Добавляем ключ в словарь
             objDictionary.Add strKey, True
          End If
      End If
   Next i

   ' Обрабатываем все подпапки текущей папки
   Dim objSubfolder As Outlook.Folder
   For Each objSubfolder In objFolder.Folders
      ProcessFolder objSubfolder, objDictionary
   Next objSubfolder
End Sub

3. Запустите скрипт:

   • Закройте редактор VBA (Alt + Q).

   • Нажмите Alt + F8, выберите RemoveDuplicateEmailsInFolderAndSubfolders и нажмите Run.

   • Выберите папку, в которой нужно удалить дубликаты.

Пример:

 Если вы выберете папку "Входящие", скрипт обработает все письма в ней, а также во всех подпапках (например, "Входящие/Работа", "Входящие/Личное" и т.д.).

Примечания:

1. Резервное копирование:

   • Перед запуском скрипта рекомендуется сделать резервную копию писем (например, экспортировать папку в .pst).

2. Производительность:

   • Если писем очень много, выполнение скрипта может занять некоторое время.

3. Критерии дубликатов:

   • В текущем скрипте дубликаты определяются по теме, отправителю и дате получения. Если нужно изменить критерии, отредактируйте строку:

strKey = objItem.Subject & "|" & objItem.SenderEmailAddress & "|" & Format(objItem.ReceivedTime, "yyyy-mm-dd hh:nn:ss")

20 тысяч дублей обрабатывается около 15-20 минут, все это время Outlook будет висеть. Progressbar не предусмотрен, так как это замедлит выполнение скрипта.