Main Area and Open Discussion > General Software Discussion

Looking for a utility to safely remove duplicate contacts from Microsoft Outlook

<< < (2/2)

Darwin:
I actually purchased a couple of the mapistore apps (duplicate email cleaner and duplicate contacts cleaner) and wound up going back to them for a refund because with the plug-ins installed my Outlook RAM usage went from ~35MB to well over 180 and I couldn't "tame" this behaviour. They may have cleaned up their resource usage as this was over a year ago.

Added in edit: Sounds like they have revised these plug-ins - maybe I should take another look because, as Carol notes, the feature set is impressive and had it not been for the resource use, I would have kept 'em...

vixay:
For the programmatically inclined. Here's some VBA code i found some while back on the net and i edited it, added some comments ...etc. I like this method the best, as it is non-destructive and upto you what you do with it. I have used it successfully and i love it! Also include is some other code that you can try out... and using the template you can do any of your own operations if you know VBA...!

How to use?

1) Copy Code below
2) Open outlook, Tools>Macro>Visual Basic Editor (Alt + F11)
3) Insert new module
or * Alternatively you can import the attached file  "MarkTools.bas" and skip to step 7
4) Paste Code
5) Save
6) Close VBE

7) Tools>Macro>Run Macro (Alt + F8)
8) Choose "MarkDuplicateContacts"
9) Now goto your contacts folder
10) Add the column/field "FTP Site"
11) Group by that column
12) All FTP Sites that say "DELETE.ME.I.AM.A.DUPE" can be safely deleted/moved to another folder

13) You are done!



--- ---Attribute VB_Name = "MarkTools"
Public Sub MarkDuplicateContacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim lCount As Long
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
'Sort Contacts
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
'Find first valid contact
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
Set oldcontact = myitems(j)
'Process each contact from there on
'This loop compares only contacts before and after the current one
'since the list is sorted, this should work correctly as contacts
'with the same name WILL be next to each other
'This is a standard linear algorithm with a performance of O(N) (in Big O notation)
'(or so i think :))
For i = j + 1 To totalcount
  If (myitems(i).Class = olContact) Then
    Set newcontact = myitems(i)
    'if((newcontact.lastmodificationtime = oldcontact.lastmodificationtime) and
    If ((newcontact.LastNameAndFirstName = oldcontact.LastNameAndFirstName) And _
        (newcontact.FileAs = oldcontact.FileAs) And _
        (newcontact.PagerNumber = oldcontact.PagerNumber) And _
        (newcontact.HomeTelephoneNumber = oldcontact.HomeTelephoneNumber) And _
        (newcontact.BusinessTelephoneNumber = oldcontact.BusinessTelephoneNumber) And _
        (newcontact.BusinessAddress = oldcontact.BusinessAddress) And _
        (newcontact.Email1Address = oldcontact.Email1Address) And _
        (newcontact.HomeAddress = oldcontact.HomeAddress) And _
        (newcontact.CompanyName = oldcontact.CompanyName)) Then
      'use FTPSite as a flag to mark duplicates
      newcontact.FTPSite = "DELETE.ME.I.AM.A.DUPE"
      newcontact.Save
      lCount = lCount + 1
    End If
    Set oldcontact = newcontact
  End If
Next i
MsgBox lCount & " Duplicate contacts found."
End Sub

Public Sub MarkBlankNumberContacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim lCount As Long
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
'Sort Contacts
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
l = 0
'Find first valid contact
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
'Process each contact from there on
'Check if ALL the possible phone number fields are blank...
'IF and only IF all are blank then can we mark the contact
For i = j + 1 To totalcount
  If (myitems(i).Class = olContact) Then
    Set newcontact = myitems(i)
    If ((newcontact.AssistantTelephoneNumber = vbNullString) And _
        (newcontact.BusinessFaxNumber = vbNullString) And _
        (newcontact.BusinessTelephoneNumber = vbNullString) And _
        (newcontact.Business2TelephoneNumber = vbNullString) And _
        (newcontact.CarTelephoneNumber = vbNullString) And _
        (newcontact.CompanyMainTelephoneNumber = vbNullString) And _
        (newcontact.HomeFaxNumber = vbNullString) And _
        (newcontact.HomeTelephoneNumber = vbNullString) And _
        (newcontact.Home2TelephoneNumber = vbNullString) And _
        (newcontact.MobileTelephoneNumber = vbNullString) And _
        (newcontact.OtherFaxNumber = vbNullString) And _
        (newcontact.OtherTelephoneNumber = vbNullString) And _
        (newcontact.PrimaryTelephoneNumber = vbNullString) And _
        (newcontact.RadioTelephoneNumber = vbNullString) And _
        (newcontact.PagerNumber = vbNullString)) Then
      'use FTPSite as a flag to mark Deletion
      newcontact.FTPSite = "DELETE.ME.NO.NUMBERS"
      newcontact.Save
      lCount = lCount + 1
    End If
  End If
Next i
MsgBox lCount & " Contacts with no numbers found."
End Sub

Sub DisplayViewDef()
'Displays the XML definition of a View object

    Dim olApp As Outlook.Application
    Dim objName As Outlook.NameSpace
    Dim objViews As Outlook.Views
    Dim objView As Outlook.View

    Set olApp = New Outlook.Application
    Set objName = olApp.GetNamespace("MAPI")
    Set objViews = objName.GetDefaultFolder(olFolderInbox).Views
     
    'Return a view called Table View if it already exists, else create one
    Set objView = objViews.Item("Table View")
    If objView Is Nothing Then
          Set objView = objViews.Add("Table View", olTableView, olViewSaveOptionAllFoldersOfType)
    End If
    MsgBox olApp.ActiveExplorer.CurrentView.XML
    MsgBox objView.XML
End Sub

lh66:
I would recommend trying out http://www.scrubly.com to remove duplicates. They have a free option to try out

Curt:
today's deal is "1-Click Duplicate Delete for Outlook PC Software with a 50% off Discount Coupon Code - Quick and Easy Cleanup of Duplicate Items in Outlook"


http://www.bitsdujour.com/software/1-click-duplicate-delete-for-outlook/ $40 today $20

Navigation

[0] Message Index

[*] Previous page