open source removing duplicate contacts

[cinnamngrl]

I wrote this macro to remove duplicates. You need to "Show Office
Assistant" in the help menu to display balloon. This macro is run in
visual basic editor.

It is slow and limited. It goes one by one and you can select one to
delete but I would like to work on combining/updating contact info. I
am posting it to get some suggestions.

Sub doubselect()
Set olApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set allcontacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
Debug.Print allcontacts.Count & " Contacts in total"
allcontacts.Sort "[LastName]"
For Each itm In allcontacts
funame = itm.FullName
Set dbcontacts = allcontacts.Restrict("[FullName]= """ & funame &
"""")
If dbcontacts.Count > 1 Then
Debug.Print dbcontacts.Count & " of " & itm
Dim who(1 To 10, 1 To 6)
x = 0
For Each db In dbcontacts
x = x + 1
who(x, 1) = db.BusinessTelephoneNumber
who(x, 2) = db.HomeTelephoneNumber
who(x, 3) = db.Email1Address
who(x, 4) = db.CreationTime
who(x, 5) = db.User1
who(x, 6) = db.FullName

Next

If x > 5 Then x = 5
Set inq = Assistant.NewBalloon

With inq
.Heading = "Available in Contacts for " & funame
.Text = "Select one to delete"
For i = 1 To x
.Labels(i).Text = "name " & dbcontacts(i) & Chr(13) & "work # " &
who(i, 1) & Chr(13) & "home # " & who(i, 2) & Chr(13) & "email " & who
(i, 3) & Chr(13) & "added " & who(i, 4) & Chr(13) & "user1 " & who(i,
5) & Chr(13) & Chr(13)
Next
.Button = msoButtonSetOK
Debug.Print where
End With
Select Case inq.Show
Case 1
dbcontacts(1).Delete
Case 2
dbcontacts(2).Delete
Case 3
dbcontacts(3).Delete
Case 4
dbcontacts(4).Delete
Case 5
dbcontacts(5).Delete
Case Else

End Select

End If
Next

End Sub

 

[cinnamngrl]

OOPS I didn't think about the way carriage returns would post. I put
in the _

 

[Ken Slovak - [MVP - Outlook]]

Some tips:

1. If this is running in the Outlook VBA project replace the lines
instantiating olApp and myOlApp with this:
Set myOlApp = Application

It doesn't look like you're using olApp.

2. Fully qualify all declarations and don't use late binding. For example:

Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim db As Outlook.ContactItem
Dim dbcontacts As Outlook.Items
etc.

early bound code runs much faster than late bound code.


3. If this is for an Exchange mailbox don't use Restrict in this case, use
Find and FindNext. Restrictions live on the server for 8 days by default and
can bring a server to its knees if there are lots of them on a folder.

4. Use more With...End With blocks where you access an object often, for
example in the loop where you read various db properties such as
CreationTime, User1, etc.

5. If you only want certain specific properties use the SetColumns method
after you get the folder Items collection:

dbcontacts.SetColumns "BusinessTelephoneNumber, HomeTelephoneNumber,
Email1Address, CreationTime, User1, FullName" 'long string there watch for
wrap

Make sure to use dbcontacts.ResetColumns at the end of your code.

6. Use the value of inq.Show as an index to delete:
dbcontacts(inq.Show).Delete instead of that Case block.

I'd also probably use some sort of grid control to display the contacts in a
form and let the user select one or more rows, but that's a heck of a lot
more code and requires an available grid control.

I wrote this macro to remove duplicates. You need to "Show Office
Assistant" in the help menu to display balloon. This macro is run in
visual basic editor.

It is slow and limited. It goes one by one and you can select one to
delete but I would like to work on combining/updating contact info. I
am posting it to get some suggestions.

Sub doubselect()
Set olApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set allcontacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
Debug.Print allcontacts.Count & " Contacts in total"
allcontacts.Sort "[LastName]"
For Each itm In allcontacts
funame = itm.FullName
Set dbcontacts = allcontacts.Restrict("[FullName]= """ & funame &
"""")
If dbcontacts.Count > 1 Then
Debug.Print dbcontacts.Count & " of " & itm
Dim who(1 To 10, 1 To 6)
x = 0
For Each db In dbcontacts
x = x + 1
who(x, 1) = db.BusinessTelephoneNumber
who(x, 2) = db.HomeTelephoneNumber
who(x, 3) = db.Email1Address
who(x, 4) = db.CreationTime
who(x, 5) = db.User1
who(x, 6) = db.FullName

Next

If x > 5 Then x = 5
Set inq = Assistant.NewBalloon

With inq
.Heading = "Available in Contacts for " & funame
.Text = "Select one to delete"
For i = 1 To x
.Labels(i).Text = "name " & dbcontacts(i) & Chr(13) & "work # " &
who(i, 1) & Chr(13) & "home # " & who(i, 2) & Chr(13) & "email " & who
(i, 3) & Chr(13) & "added " & who(i, 4) & Chr(13) & "user1 " & who(i,
5) & Chr(13) & Chr(13)
Next
.Button = msoButtonSetOK
Debug.Print where
End With
Select Case inq.Show
Case 1
dbcontacts(1).Delete
Case 2
dbcontacts(2).Delete
Case 3
dbcontacts(3).Delete
Case 4
dbcontacts(4).Delete
Case 5
dbcontacts(5).Delete
Case Else

End Select

End If
Next

End Sub

 

[cinnamngrl]

early bound code runs much faster than late bound code

Thankyou for explaining this.

It doesn't look like you're using olApp >> if you can't tell , the littleI know comes from copying sample code.

3. If this is for an Exchange mailbox don't use Restrict in this case, use
Find and FindNext. Restrictions live on the server for 8 days by default and
can bring a server to its knees if there are lots of them on a folder.

This is confusing to me. I would say no, I am not using an exchange
mailbox at home or work (I think).
how can the the restrict affect anything when the macro is not
running? It does make sense that they weigh things down. as they
have slow and sometimes freeze if i try to do anything else with my
desktop.

Hey, do have any idea why I need to use four sets of quotes to
restrict my collections? This happens when I need to use a variable.
if it is constant then I only need three sets of quotes, but I can't
figure out why I need more than one. I only know that it doesn't work
otherwise.


this is helpful. I will probably have more questions but I need to
get up at 5. thankyou

Some tips:

1. If this is running in the Outlook VBA project replace the lines
instantiating olApp and myOlApp with this:
    Set myOlApp = Application

It doesn't look like you're using olApp.

2. Fully qualify all declarations and don't use late binding. For example:

    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim db As Outlook.ContactItem
    Dim dbcontacts As Outlook.Items
    etc.

early bound code runs much faster than late bound code.

3. If this is for an Exchange mailbox don't use Restrict in this case, use
Find and FindNext. Restrictions live on the server for 8 days by default and
can bring a server to its knees if there are lots of them on a folder.

4. Use more With...End With blocks where you access an object often, for
example in the loop where you read various db properties such as
CreationTime, User1, etc.

5. If you only want certain specific properties use the SetColumns method
after you get the folder Items collection:

    dbcontacts.SetColumns "BusinessTelephoneNumber, HomeTelephoneNumber,
Email1Address, CreationTime, User1, FullName" 'long string there watch for
wrap

Make sure to use dbcontacts.ResetColumns at the end of your code.

6. Use the value of inq.Show as an index to delete:
dbcontacts(inq.Show).Delete instead of that Case block.

I'd also probably use some sort of grid control to display the contacts in a
form and let the user select one or more rows, but that's a heck of a lot
more code and requires an available grid control.

I wrote this macro to remove duplicates.  You need to "Show Office
Assistant" in the help menu to display balloon.  This macro is run in
visual basic editor.

It is slow and limited.  It goes one by one and you can select one to
delete but I would like to work on combining/updating contact info.  I
am posting it to get some suggestions.

Sub doubselect()
Set olApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set allcontacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
Debug.Print allcontacts.Count & " Contacts in total"
allcontacts.Sort "[LastName]"
For Each itm In allcontacts
funame = itm.FullName
Set dbcontacts = allcontacts.Restrict("[FullName]= """ & funame &
"""")
If dbcontacts.Count > 1 Then
Debug.Print dbcontacts.Count & " of " & itm
Dim who(1 To 10, 1 To 6)
x = 0
For Each db In dbcontacts
x = x + 1
who(x, 1) = db.BusinessTelephoneNumber
who(x, 2) = db.HomeTelephoneNumber
who(x, 3) = db.Email1Address
who(x, 4) = db.CreationTime
who(x, 5) = db.User1
who(x, 6) = db.FullName

Next

If x > 5 Then x = 5
Set inq = Assistant.NewBalloon

  With inq
   .Heading = "Available in Contacts for " & funame
   .Text = "Select one to delete"
   For i = 1 To x
   .Labels(i).Text = "name " & dbcontacts(i) & Chr(13) & "work # " &
who(i, 1) & Chr(13) & "home # " & who(i, 2) & Chr(13) & "email " & who
(i, 3) & Chr(13) & "added " & who(i, 4) & Chr(13) & "user1  " & who(i,
5) & Chr(13) & Chr(13)
   Next
   .Button = msoButtonSetOK
   Debug.Print where
   End With
Select Case inq.Show
Case 1
dbcontacts(1).Delete
Case 2
dbcontacts(2).Delete
Case 3
dbcontacts(3).Delete
Case 4
dbcontacts(4).Delete
Case 5
dbcontacts(5).Delete
Case Else

End Select

End If
Next

End Sub- Hide quoted text -

- Show quoted text -

 

[Ken Slovak - [MVP - Outlook]]

Look at the Navigation Pane when displaying the Folder List. If it says
something like "Personal Folders" or "Outlook Today" at the top of the
folder list you're using a PST file and not an Exchange mailbox. If you're
using Exchange it would say something like "Mailbox - your name here".

The quoting is confusing because of how it works with multiple quote
characters. I usually try to use single quotes where possible or a Chr(34)
instead (that's a quote character) to make reading the code less confusing.

early bound code runs much faster than late bound code

Thankyou for explaining this.

It doesn't look like you're using olApp >> if you can't tell , the little
I know comes from copying sample code.

3. If this is for an Exchange mailbox don't use Restrict in this case, use
Find and FindNext. Restrictions live on the server for 8 days by default
and
can bring a server to its knees if there are lots of them on a folder.

This is confusing to me. I would say no, I am not using an exchange
mailbox at home or work (I think).
how can the the restrict affect anything when the macro is not
running? It does make sense that they weigh things down. as they
have slow and sometimes freeze if i try to do anything else with my
desktop.

Hey, do have any idea why I need to use four sets of quotes to
restrict my collections? This happens when I need to use a variable.
if it is constant then I only need three sets of quotes, but I can't
figure out why I need more than one. I only know that it doesn't work
otherwise.


this is helpful. I will probably have more questions but I need to
get up at 5. thankyou