Macro for Delete Duplicate Emails in outlook2010

Option Explicit

Dim lCount As Long 'to count the deleted items


'the macro that delete the duplicated entries
Public Sub DeleteDuplicatedEntries()
  Dim rep As String, choice As Integer
  Dim olCtx As OutlookContext

  'loop for user interaction
'  Do
'    rep = InputBox("This macro delete duplicates entries" & vbNewLine _
'                 & "for a given category of items." & vbNewLine & vbNewLine _
'                 & "1 = emails" & vbNewLine _
'                 & "2 = calendar" & vbNewLine _
'                 & "3 = tasks" & vbNewLine _
'                 & "4 = contacts" & vbNewLine & vbNewLine _
'                 & "q = quit the macro", "Question")
    rep = 1
    If IsNumeric(rep) Then
      choice = CInt(rep)
      If (choice >= 1) And (choice <= 4) Then
        'initialize some global var
        lCount = 0
      
        'get a reference to the Outlook application and session.
        Set olCtx = New OutlookContext
        olCtx.Create (choice)
      
        'ok to begin process ?
        'If MsgBox(olCtx.GetQuestion(), vbYesNo + vbQuestion, "Question") = vbYes Then
        If vbYes = vbYes Then
      
          'set a start folder
          If (olCtx.SetStartFolder()) Then
      
            'process the first folder (and other by recursive calls to ProcessFolder)
            ProgressBox.Show
            Call ProcessFolder(olCtx)
            ProgressBox.Hide
            'Call MsgBox(CStr(lCount) & " " & olCtx.GetMessage(), vbOKOnly, "Info")
      
          End If
        End If
        Set olCtx = Nothing
      End If
    End If
'  Loop Until UCase(rep) = "Q"
End Sub

'the process folder : each folder item is compared to the previous to delete duplicated entries
Private Sub ProcessFolder(olCtx As OutlookContext)
  Dim i As Long
  Dim strLastKey As String, strNewKey As String, strDateKey As Date
  Dim olNewFolder As Outlook.MAPIFolder
  Dim olTempItem As Object     'could be various item types
  Dim myItems As Outlook.Items 'a local copy of the collection
  
  'initialize last key string
  strLastKey = ""
   
  'copy the collection (it's obligatory for the sort) and sort them
  Set myItems = olCtx.GetFolder().Items
  On Error Resume Next
  Call myItems.Sort("[" & olCtx.GetSortKey() & "]", True)
  On Error GoTo 0
  
  'loop through the items in the current folder (backwards in this case of items to delete)
  For i = myItems.Count To 1 Step -1
    Set olTempItem = myItems(i)
    
    'process only if type is OK
    If TypeName(olTempItem) = olCtx.GetTypeName() Then
      On Error Resume Next
      With olTempItem
        'strDateKey = olCtx.GetDateKey(olTempItem)
        'If strDateKey = Date Then
        'Exit Sub
        'End If
        On Error Resume Next
        strNewKey = olCtx.GetCurrKey(olTempItem)
        
        'uncomment next lines for debugging
        'Debug.Print Len(olTempItem.Subject)
        'Debug.Print strNewKey
        'Debug.Print strLastKey
        'Debug.Print
        
        'update percent in progressbox
        ProgressBox.Increment (myItems.Count - i + 1) / myItems.Count * 100
        
        'check to see if a match is found
        If strNewKey = strLastKey Then
          
          'comment the next line if you want just debug, not delete for this moment
          olTempItem.Delete
          
          'count deleted items
          lCount = lCount + 1
        End If

        'memorize last key found
        strLastKey = strNewKey
      End With
    End If
  Next

  'loop through and search each subfolder of the current folder.
  For Each olNewFolder In olCtx.GetFolder().Folders
    Call olCtx.SetFolder(olNewFolder)
    Call ProcessFolder(olCtx)
  Next

End Sub

Select allOpen in new window

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)

'add this line

msgbox "This sub objNewMailItems_ItemAdd fired correctly!"

Select allOpen in new window