VBA Outlook 2000 Delete contacts by categorie

  • Thread starter Thread starter Céline Brien
  • Start date Start date
C

Céline Brien

Hi everybody,
I am trying to delete contacts by categorie. See codes below.
No message, no nothing. It just don't work.
Can you help ?
Many thanks,
Céline
-------------------------------------------------------------------
Sub DeleteOutlookContacts()
On Error Resume Next
Dim StrContacts As String

Dim OlApp As New Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim OlFolder As Outlook.MAPIFolder
Dim OlItems As Outlook.Items
Dim OlContact As Outlook.ContactItem

Set OlMapi = OlApp.GetNamespace("MAPI")
Set OlFolder = OlMapi.GetDefaultFolder(olFolderContacts)
Set OlItems = OlFolder.Items

For Each OlContact In OlItems
If OlContact.Categories = "Excel" Then
OlContact.Delete
End If
Next OlContact

MsgBox StrContacts

Set OlContact = Nothing
Set OlItems = Nothing
Set OlFolder = Nothing
Set OlMapi = Nothing
Set OlApp = Nothing

End Sub
 
A For loop used to delete items from a collection should be a down counting
For loop. Otherwise at best you will delete only half the items in the
collection because the loop index is being changed within the loop.

For i = Items.Count To 1 Step -1

Categories can hold more than one category. It's probably best not to use an
equality comparison as you are using but to use something like InStr.

If InStr(1,OlContact.Categories, "Excel") Then
 
Hi everybody,
Hi Ken,
Thank you very much for your answer.
I get an error message on this line : If InStr(1, OlContact.Categories,
"Excel") Then
The message is number 91. Variable objet ou variable de bloc With non
définie.
Your help is greatly appreciated,
Céline

Sub DeleteOutlookContactsCategoriesExcel()

Dim StrContacts As String
Dim OlApp As New Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim OlFolder As Outlook.MAPIFolder
Dim OlItems As Outlook.Items
Dim OlContact As Outlook.ContactItem
Dim i As Long
Set OlMapi = OlApp.GetNamespace("MAPI")
Set OlFolder = OlMapi.GetDefaultFolder(olFolderContacts)
Set Items = OlFolder.Items
For i = Items.Count To 1 Step -1
If InStr(1, OlContact.Categories, "Excel") Then
OlContact.Delete
End If
Next
MsgBox StrContacts
Set OlContact = Nothing
Set OlItems = Nothing
Set OlFolder = Nothing
Set OlMapi = Nothing
Set OlApp = Nothing

End Sub
 
You need to instantiate the contact item in the loop. As it is the object is
not assigned to anything.

For i = Items.Count To 1 Step -1
Set OlContact = Items(i)
If InStr(1, OlContact.Categories, "Excel") Then
OlContact.Delete
End If
Next

It's also not a good idea to use an object or collection name that is the
same as the object or collection itself if only because it's confusing.

Dim colItems As Outlook.Items
or
Dim oItems As Outlook.Items
and so on

Using the code as it is might also be a problem if the Items collection also
holds distribution list items. Assigning a ContactItem object to a DL item
causes an error. With no error handler your code would just stop. If you use
On Error Resume Next the If test following the assignment would fail. So
either make OlContact an Object and use late binding if you also want to
include DL's or test for either the .Class (= olContact) or that the
..MessageClass string property includes "IPM.Contact" in it before assigning
to a ContactItem variable.
 
Hi everybody,
Hi Ken,
It finally worked ! See codes below.
Thank you so so much for your precious help and your patience and your
good explications.
Céline

Sub DeleteOutlookContactsExcel()
Dim StrContacts As String
Dim olApp As New Outlook.Application
Dim olMapi As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim olContact As Outlook.ContactItem
Dim i As Long
Set olMapi = olApp.GetNamespace("MAPI")
Set olFolder = olMapi.GetDefaultFolder(olFolderContacts)
Set colItems = olFolder.Items
For i = colItems.Count To 1 Step -1
Set colContact = colItems(i)
If InStr(1, colContact.Categories, "Excel") Then
colContact.Delete
End If
Next
MsgBox StrContacts
Set olContact = Nothing
Set colItems = Nothing
Set olFolder = Nothing
Set olMapi = Nothing
Set olApp = Nothing
End Sub
 
Back
Top