GetMailKey = objMail.Subject & objMail.Body GetMailKey = objMail.Subject & objMail.HTMLBody
![mapi outlook duplicate remover mapi outlook duplicate remover](https://manuals.gfi.com/en/kerio/connect/content/assets/account-settings-error-reporting.png)
Also works for calendar invites, etc.: Function GetMailKey( ByRef objMail As Object) As String On Error GoTo NoHTML
MAPI OUTLOOK DUPLICATE REMOVER FULL
Adapt as needed, but I think if the subject and full body are the same, there's no point in checking anything else.
MAPI OUTLOOK DUPLICATE REMOVER MOD
' Keep track of this mail in case we end up needing to build a dictionary Set objLastMail = objMailĮnd If ' Progress update If index Mod 10 = 0 Thenĭebug.Print index & " Remaining." End Ifĭebug.Print "Finished moving Duplicate Emails" End SubĪnd the helper function referenced above for "uniquely identifying" an email. 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.Add GetMailKey(objLastMail), True End If ' Now check the current mail item to see if it's a duplicateĭebug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
![mapi outlook duplicate remover mapi outlook duplicate remover](https://topcrack.net/wp-content/uploads/2021/05/Shoviv-Outlook-Duplicate-Remover-With-Crack-Key-Free-Download.jpg)
' Add the last mail to the dictionary if it hasn't been tracked yet If Not objLastMail Is Nothing Thenĭebug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates." Previous mail was " & lastReceived _Įxit Sub ElseIf received = lastReceived Then ' Might be a duplicate track mail contents until this recieved time changes. LastReceived = "" For index = totalCount - 1 To 1 Step - 1 Set objMail = allMails(index)ĭebug.Print "Error: Expected emails to be in order of date recieved. On Error GoTo 0 If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = ( "Duplicates")ĭebug.Print "Sorting " & olFolder.Name & " by ReceivedTime." Set allMails = olFolder.ItemsĪllMails.Sort "", True Dim totalCount As Long, index As Longĭebug.Print totalCount & " Items to Process." With ( "MAPI")Įnd With If olFolder Is Nothing Then Exit Sub On Error Resume Next Set olDuplicatesFolder = olFolder.Folders( "Duplicates") Sub DeleteDuplicateEmails()ĭim objMail As Object, objDic As Object, objLastMail As Object Dim olFolder As Folder, olDuplicatesFolder As Folderĭim strCheck As String Dim received As Date, lastReceived As Date Set objDic = CreateObject( "scripting.dictionary") This script also takes into account the fact that some items use an HTMLBody for the full message definition, and others don't have that property. Once the date changes, you know you'll never see another email with the prior date, therefore, they won't be duplicates, so you can clear your dictionary on each date change. There's no need to maintain a giant dictionary of every email you've seen if you are processing emails in a deterministic order (e.g. Here's a script that takes advantage of sorting emails to check for duplicates much more efficiently. MsgBox "No duplicates found" End If End Sub
![mapi outlook duplicate remover mapi outlook duplicate remover](https://www.mapilab.com/images/screenshots/duplicate_remover/search_outlook_email_duplicates_1.png)
MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details" Else ObjDic.Add strCheck, True End If Next If objTF.Line > 2 Then ObjTF.WriteLine Replace(objItem.Subject, ", ", Chr( 32)) StrCheck = Replace(strCheck, ", ", Chr( 32)) StrCheck = objItem.Subject & "," & objItem.Body & "," On Error GoTo 0 If olFolder2 Is Nothing Then Set olFolder2 = ( "removed items")įor lngCnt = To 1 Step - 1 Set objItem = olFolder.Items(lngCnt) If olFolder Is Nothing Then Exit Sub On Error Resume Next Set olFolder2 = olFolder.Folders( "removed items") ObjTF.WriteLine "Subject" Set olApp = Outlook.Application Set objTF = objFSO.CreateTextFile(strPath)
![mapi outlook duplicate remover mapi outlook duplicate remover](https://www.slipstick.com/images/2014/outlook/imap-folder-properties.png)
Set objFSO = CreateObject( "scripting.filesystemobject") Tested on Outlook 2016 Const strPath = "c: empdeleted msg.csv" Sub DeleteDuplicateEmails()ĭim 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ĭim olNS As NameSpace Dim olFolder As Folderĭim strCheck As String Set objDic = CreateObject( "scripting.dictionary") I have changed the test to subject and body Updated: Checking for size surprisingly missed a number of dupes, even for otherwise identical mail items.