Outlook удалить дубликаты сообщений

[Beliy.IV]

Привет Всем.
Ребят, подскажите рабочий плагин для outlook 2010 без ограничения, в ящике более 1000 писем и удалять по 5-10 не вариант.

Нужно навести порядок за 3 года активного использования почты.

[a_axe]

Beliy.IV, попробуйте код отсюда (http://qaru.site/questions/1623379/remove-duplicate-outlook-items-from-a-folder).
Тестировал на Outlook 2013, код отработал корректно.
Необходимо предварительно создать файл "c:\temp\deleted msg.csv".
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

[mwz]

Beliy.IV, поищите ODIR

[Beliy.IV]

Beliy.IV, поищите ODIR »
Не устанавливается dll, я пробовал.


Beliy.IV, попробуйте код отсюда.
Тестировал на Outlook 2013, код отработал корректно.
Необходимо предварительно создать файл "c:\temp\deleted msg.csv". »
Создал макрос, НО проверил на чистой почте без дубликатов, он из 1000 писем отобрал 200, которые я не смог найти в входящих, т.е. переместил, а дубликата я не нашёл, или он работает что 1 копию удаляет, а вторую помещает в removed items, наверное так? т.е. их нужно снова вкинуть в входящие ?

[Beliy.IV]

Не, чёт не пойму вот у меня 5к сообщений, он мне перемещает 3,5к в removed items, я смотрю туда и пытаюсь найти такие же в входящих - нет таких

т.е. в период с 12 до 13 у меня в входящих 1 сообщение, а в removed items 6 писем ( есть повторяющиеся ), объсните как пользоваться.

Ещё при большом кол-ве писем выскакивает ошибка

[a_axe]

т.е. переместил, а дубликата я не нашёл »
Тут вероятен следующий вариант: код сравнивает тему письма и текст письма, не обращая внимания на емейл отправителя и время отправки, поэтому письма без текста с темой например "Re:" (или любыми другими одинаковыми) он будет считать дубликатами. Перемещает код вторую и последующие копии письма в пределах выбранной папки.
Можно сравнивать например также по email отправителя и времени отправки письма:
Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails_2()

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 & "," & objItem.SenderEmailAddress & "," & objItem.SentOn & ","
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


Попробуйте, отпишитесь по результатам.

[Beliy.IV]

Попробовал теперь ошибка выскакивает постоянно и процесс не завершается, т.е. не одного письме не отбирает. Ошибка ссылается на strCheck = objItem.Subject & "," & objItem.Body & "," & objItem.SenderEmailAddress & "," & objItem.SentOn & ",

Правильно ли я понимаю, что этот код это module, файл я создаю пустой

[Iska]

теперь ошибка выскакивает постоянно »
Какая? Та же самая?

[Beliy.IV]

Какая? Та же самая? »
Нет номер другой, и при нажатии на дебаг кидает на строчку кода которую я привёл выше.

[Iska]

«Объект не поддерживает данное свойство или метод». Становитесь в режиме отладки и смотрите на objItem и на каждый objItem.bla-bla-bla в этой строке, чего и у кого там нет.

[a_axe]

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

[Beliy.IV]

чего и у кого там нет »
скорей всего тем то и нет или текста сообщения и т.д.

Эх, такой банальный функционал и отсутствует в офисе. придется сидеть с дубликатами и файлами почты в 50гб

[Beliy.IV]

Ребят, не подскажите что делать то.
три файла по 10гб на почте, как бы удалить дубликаты.

[Iska]

Beliy.IV, Вы опробовали то, что я написал ранее:
Становитесь в режиме отладки и смотрите на objItem и на каждый objItem.bla-bla-bla в этой строке, чего и у кого там нет. »
?