Outlook удалить дубликаты сообщений
Привет Всем.
Ребят, подскажите рабочий плагин для outlook 2010 без ограничения, в ящике более 1000 писем и удалять по 5-10 не вариант.
Нужно навести порядок за 3 года активного использования почты.
|
Beliy.IV, попробуйте код отсюда.
Тестировал на 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
|
Не устанавливается dll, я пробовал.
Цитата:
Цитата a_axe
Beliy.IV, попробуйте код отсюда.
Тестировал на Outlook 2013, код отработал корректно.
Необходимо предварительно создать файл "c:\temp\deleted msg.csv". »
|
Создал макрос, НО проверил на чистой почте без дубликатов, он из 1000 писем отобрал 200, которые я не смог найти в входящих, т.е. переместил, а дубликата я не нашёл, или он работает что 1 копию удаляет, а вторую помещает в removed items, наверное так? т.е. их нужно снова вкинуть в входящие ? |
Вложений: 1
Не, чёт не пойму вот у меня 5к сообщений, он мне перемещает 3,5к в removed items, я смотрю туда и пытаюсь найти такие же в входящих - нет таких
т.е. в период с 12 до 13 у меня в входящих 1 сообщение, а в removed items 6 писем ( есть повторяющиеся ), объсните как пользоваться.
Ещё при большом кол-ве писем выскакивает ошибка
|
Цитата:
Цитата Beliy.IV
т.е. переместил, а дубликата я не нашёл »
|
Тут вероятен следующий вариант: код сравнивает тему письма и текст письма, не обращая внимания на емейл отправителя и время отправки, поэтому письма без текста с темой например "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
Попробуйте, отпишитесь по результатам. |
Попробовал теперь ошибка выскакивает постоянно и процесс не завершается, т.е. не одного письме не отбирает. Ошибка ссылается на
Код:
strCheck = objItem.Subject & "," & objItem.Body & "," & objItem.SenderEmailAddress & "," & objItem.SentOn & ",
Правильно ли я понимаю, что этот код это module, файл я создаю пустой |
Цитата:
Цитата Beliy.IV
теперь ошибка выскакивает постоянно »
|
Какая? Та же самая? |
Вложений: 1
Нет номер другой, и при нажатии на дебаг кидает на строчку кода которую я привёл выше. |
«Объект не поддерживает данное свойство или метод». Становитесь в режиме отладки и смотрите на objItem и на каждый objItem.bla-bla-bla в этой строке, чего и у кого там нет.
|
К сожалению нет доступа к outlook, по раздумью речь может идти например о том, что в в папке присутствуют например приглашения на собрания, либо неотправленные сообщения (черновики), у которых свойство "отправлено" вероятно может отсутствовать.
|
скорей всего тем то и нет или текста сообщения и т.д.
Эх, такой банальный функционал и отсутствует в офисе. придется сидеть с дубликатами и файлами почты в 50гб |
Ребят, не подскажите что делать то.
три файла по 10гб на почте, как бы удалить дубликаты.
|
Beliy.IV, Вы опробовали то, что я написал ранее:
Цитата:
Цитата Iska
Становитесь в режиме отладки и смотрите на objItem и на каждый objItem.bla-bla-bla в этой строке, чего и у кого там нет. »
|
?
|
Время: 15:48.
© OSzone.net 2001-
