Удалить дубликаты элементов Outlook из папки

Question

Удалить дубликаты элементов Outlook из папки

вопрос

Outlook 2016 поврежден, когда я перемещал элементы из онлайн-архива в файл pst.
Файл PST был восстановлен.... но многие элементы (~7000) дублируются 5 раз
Существуют различные типы элементов, стандартные сообщения, приглашения на собрания и т. Д.

что я пытался
Я посмотрел на существующие решения и инструменты, в том числе:

инструменты для удаления дубликатов - ни один из них не был бесплатным, кроме пробной версии для удаления 10 элементов одновременно.
Разнообразные программные решения, в том числе:
Усилия Джейкоба Хильдербранда, основанные на Excel
Макрос в Outlook для удаления дубликатов писем-

Я решил пойти по маршруту кода, поскольку он был относительно простым и получить больше контроля над тем, как сообщалось о дубликатах.

Я опубликую свое собственное решение ниже, поскольку оно может помочь другим.

Я хотел бы увидеть другие потенциальные подходы (возможно, powershell) к решению этой проблемы, которые могут быть лучше, чем у меня.

7

vba outlook outlook-vba outlook-2016

Источник

user641067 08 янв '16 в 03:47

2 ответа

Другие вопросы по тегам vba outlook outlook-vba outlook-2016

user641067 08 янв '16 в 03:47 2016-01-08 03:47 · Answer 1 · 2016-01-08 03:47

Подход ниже:

Предоставляет пользователям приглашение выбрать папку для обработки
Проверяет дубликаты на основе темы, отправителя, CreationTime и размера
Перемещены (а не удалены) любые дубликаты в подпапку (удаленные элементы) обрабатываемой папки.
Создайте файл CSV - сохраненный по пути в StrPath создать внешнюю ссылку на Outlook из писем, которые были перемещены.

Обновлено: при проверке размера неожиданно пропущено множество дубликатов даже для идентичных почтовых отправлений. Я изменил тест на subject а также body

Проверено на Outlook 2016

Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails()

Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object

Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

If olFolder Is Nothing Then Exit Sub

On Error Resume Next
Set olFolder2 = olFolder.Folders("removed items")
On Error GoTo 0

If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("removed items")


For lngCnt = olFolder.Items.Count To 1 Step -1

Set objItem = olFolder.Items(lngCnt)

strCheck = objItem.Subject & "," & objItem.Body & ","
strCheck = Replace(strCheck, ", ", Chr(32))

    If objDic.Exists(strCheck) Then
       objItem.Move olFolder2
       objTF.WriteLine Replace(objItem.Subject, ", ", Chr(32))
    Else
        objDic.Add strCheck, True
    End If
Next

If objTF.Line > 2 Then
    MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details"
Else
    MsgBox "No duplicates found"
End If
End Sub

user529618 06 июл '18 в 17:12 2018-07-06 17:12 · Answer 2 · 2018-07-06 17:12

Вот скрипт, который использует сортировку писем для более эффективной проверки на наличие дубликатов.

Нет необходимости поддерживать гигантский словарь каждого письма, которое вы видели, если вы обрабатываете письма в детерминированном порядке (например, дата получения). Когда дата изменится, вы знаете, что никогда не увидите другого электронного письма с предыдущей датой, поэтому они не будут дубликатами, поэтому вы можете очищать свой словарь при каждом изменении даты.

Этот сценарий также учитывает тот факт, что некоторые элементы используют HTMLBody для полного определения сообщения, а другие не имеют этого свойства.

Sub DeleteDuplicateEmails()
    Dim allMails As Outlook.Items
    Dim objMail As Object, objDic As Object, objLastMail As Object
    Dim olFolder As Folder, olDuplicatesFolder As Folder
    Dim strCheck As String
    Dim received As Date, lastReceived As Date        

    Set objDic = CreateObject("scripting.dictionary")
    With Outlook.Application.GetNamespace("MAPI")
        Set olFolder = .PickFolder
    End With
    If olFolder Is Nothing Then Exit Sub

    On Error Resume Next
    Set olDuplicatesFolder = olFolder.Folders("Duplicates")
    On Error GoTo 0
    If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")

    Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
    Set allMails = olFolder.Items
    allMails.Sort "[ReceivedTime]", True
    Dim totalCount As Long, index As Long
    totalCount = allMails.count
    Debug.Print totalCount & " Items to Process..."

    lastReceived = "1/1/1987"
    For index = totalCount - 1 To 1 Step -1
        Set objMail = allMails(index)
        received = objMail.ReceivedTime
        If received < lastReceived Then
            Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
                & " current is " & received
            Exit Sub
        ElseIf received = lastReceived Then
            ' Might be a duplicate track mail contents until this recieved time changes.
            ' Add the last mail to the dictionary if it hasn't been tracked yet
            If Not objLastMail Is Nothing Then
                Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
                objDic.Add GetMailKey(objLastMail), True
            End If
            ' Now check the current mail item to see if it's a duplicate
            strCheck = GetMailKey(objMail)
            If objDic.Exists(strCheck) Then
                Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
                objMail.Move olDuplicatesFolder
                DoEvents
            Else
                objDic.Add strCheck, True
            End If
            ' No need to track the last mail, since we have it in the dictionary
            Set objLastMail = Nothing
        Else
            ' This can't be a duplicate, it has a different date, reset our dictionary
            objDic.RemoveAll
            lastReceived = received
            ' Keep track of this mail in case we end up needing to build a dictionary
            Set objLastMail = objMail
        End If

        ' Progress update
        If index Mod 10 = 0 Then
            Debug.Print index & " Remaining..."
        End If
        DoEvents
    Next
    Debug.Print "Finished moving Duplicate Emails"
End Sub

И упомянутая выше вспомогательная функция для "уникальной идентификации" электронной почты. Приспосабливайтесь по мере необходимости, но я думаю, что если предмет и все тело одинаковы, нет смысла проверять что-либо еще. Также работает для календарных приглашений и т.д.:

Function GetMailKey(ByRef objMail As Object) As String
    On Error GoTo NoHTML
    GetMailKey = objMail.Subject & objMail.HTMLBody
    Exit Function
BodyKey:
    On Error GoTo 0
    GetMailKey = objMail.Subject & objMail.Body
    Exit Function
NoHTML:
    Err.Clear
    Resume BodyKey
End Function

user1655245 05 дек '20 в 22:30 2020-12-05 22:30 · Answer 3 · 2020-12-05 22:30

Я написал сценарий VBA под названием "Outlook Duplicated Items Remover".

Исходный код доступен на GitHub

Он найдет все повторяющиеся элементы в папке и ее подпапках и переместит их в специальную папку.

1

Источник

user1655245 05 дек '20 в 22:30

user14257464 11 сен '20 в 03:05 2020-09-11 03:05 · Answer 4 · 2020-09-11 03:05

Уважаемые, ОЧЕНЬ спасибо, что вы спасли мне день:-) Я упростил поиск дубликатов, так как в моем случае я импортировал несколько дубликатов из файлов PST, но полное тело письма не соответствовало, я не знаю точно почему, так как я Я уверен, что эти письма являются истинными дубликатами. Поэтому мое упрощение состоит в том, чтобы сопоставить ТОЛЬКО ОТМЕТКА ВРЕМЕНИ получения и ТЕМА. Я также добавляю исключение ошибки, которое я получал несколько раз в функции: Set olDuplicatesFolder = olFolder.Folders("Duplicates") И сделал другой формат для сообщений debug.print Итак, вот мой код, который мне очень подходит. БЛАГОДАРЮ ВАС

Attribute VB_Name = "DelDupEmails_DATE_SUBJECT"
Sub DeleteDuplicateEmails_DATE_SUBJECT()
Dim allMails As Outlook.Items
Dim objMail As Object, objDic As Object, objLastMail As Object
Dim olFolder As Folder, olDuplicatesFolder As Folder
Dim strCheck As String
Dim received As Date, lastReceived As Date

Set objDic = CreateObject("scripting.dictionary")
With Outlook.Application.GetNamespace("MAPI")
    Set olFolder = .PickFolder
End With
If olFolder Is Nothing Then Exit Sub

On Error Resume Next
Set olDuplicatesFolder = olFolder.Folders("Duplicates")
On Error GoTo 0
If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")

Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
Set allMails = olFolder.Items
allMails.Sort "[ReceivedTime]", True
Dim totalCount As Long, index As Long
totalCount = allMails.Count
Debug.Print totalCount & " Items to Process..."
'MsgBox totalCount & " Items to Process..."

lastReceived = "1/1/1987"
For index = totalCount - 1 To 1 Step -1
    Set objMail = allMails(index)
    On Error Resume Next
    received = objMail.ReceivedTime
    On Error GoTo 0
    If received < lastReceived Then
        Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
            & " current is " & received
        Exit Sub
    ElseIf received = lastReceived Then
        ' Might be a duplicate track mail contents until this recieved time changes.
        ' Add the last mail to the dictionary if it hasn't been tracked yet
        If Not objLastMail Is Nothing Then
            Debug.Print olFolder & " : Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
            'MsgBox "Found multiple emails recieved at " & lastReceived & ", checking for duplicates..."
            objDic.Add GetMailKey(objLastMail), True
        End If
        ' Now check the current mail item to see if it's a duplicate
        strCheck = GetMailKey(objMail)
        If objDic.Exists(strCheck) Then
            Debug.Print "#" & index & " - Duplicate: " & lastReceived & " " & objMail.Subject
            'Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
            'MsgBox "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
            objMail.Move olDuplicatesFolder
            DoEvents
        Else
            objDic.Add strCheck, True
        End If
        ' No need to track the last mail, since we have it in the dictionary
        Set objLastMail = Nothing
    Else
        ' This can't be a duplicate, it has a different date, reset our dictionary
        objDic.RemoveAll
        lastReceived = received
        ' Keep track of this mail in case we end up needing to build a dictionary
        Set objLastMail = objMail
    End If

    ' Progress update
    If index Mod 100 = 0 Then
        Debug.Print index & " Remaining... from " & olFolder
        'MsgBox index & " Remaining..."
    End If
    DoEvents
Next
Debug.Print "Finished moving Duplicate Emails"
MsgBox "Finished moving Duplicate Emails"

End Sub

Function GetMailKey(ByRef objMail As Object) As String
  On Error GoTo NoHTML
  'GetMailKey = objMail.Subject & objMail.HTMLBody
  GetMailKey = objMail.Subject ' & objMail.HTMLBody
  Exit Function
BodyKey:
  On Error GoTo 0
  'GetMailKey = objMail.Subject & objMail.Body
  GetMailKey = objMail.Subject ' & objMail.Body
  Exit Function
NoHTML:
  Err.Clear
  Resume BodyKey
End Function