G
Gustavo Strabeli
Hello!
I'm using below code in order to have Outlook adding email addresses to my
contacts folder.
So here's the problem: adresses are being added to my contacts however it's
inserting quotes before and after the address.
I don't know nothing about VBA, but analysing the code I deleted the Chr(34)
from the code and this problem was solved, however another problem
was raised: now all my contacts are being duplicated.
Do you know how to fix that? I mean, delete the quotes and don't have the
contacts duplicated?
Thanks a lot,
Gustavo
The code:
Sub AddRecipToContacts(objMail As Outlook.MailItem)
Dim strFind As String
Dim strAddress As String
Dim objNS As Outlook.NameSpace
Dim colContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim objRecip As Outlook.Recipient
Dim i As Integer
On Error Resume Next
' get Contacts folder and its Items collection
Set objNS = Application.GetNamespace("MAPI")
Set colContacts = _
objNS.GetDefaultFolder(olFolderContacts).Items
' process message recipients
For Each objRecip In objMail.Recipients
' check to see if the recip is already in Contacts
strAddress = AddQuote(objRecip.Address)
For i = 1 To 3
strFind = "[Email" & i & "Address] = " & _
strAddress
Set objContact = colContacts.Find(strFind)
If Not objContact Is Nothing Then
Exit For
End If
Next
' if not, add it
If objContact Is Nothing Then
Set objContact = _
Application.CreateItem(olContactItem)
With objContact
.FullName = objRecip.Name
.Email1Address = strAddress
.Save
End With
End If
Set objContact = Nothing
Next
Set objNS = Nothing
Set objContact = Nothing
Set colContacts = Nothing
End Sub
Function AddQuote(MyText) As String
AddQuote = Chr(34) & MyText & Chr(34)
End Function
I'm using below code in order to have Outlook adding email addresses to my
contacts folder.
So here's the problem: adresses are being added to my contacts however it's
inserting quotes before and after the address.
I don't know nothing about VBA, but analysing the code I deleted the Chr(34)
from the code and this problem was solved, however another problem
was raised: now all my contacts are being duplicated.
Do you know how to fix that? I mean, delete the quotes and don't have the
contacts duplicated?
Thanks a lot,
Gustavo
The code:
Sub AddRecipToContacts(objMail As Outlook.MailItem)
Dim strFind As String
Dim strAddress As String
Dim objNS As Outlook.NameSpace
Dim colContacts As Outlook.Items
Dim objContact As Outlook.ContactItem
Dim objRecip As Outlook.Recipient
Dim i As Integer
On Error Resume Next
' get Contacts folder and its Items collection
Set objNS = Application.GetNamespace("MAPI")
Set colContacts = _
objNS.GetDefaultFolder(olFolderContacts).Items
' process message recipients
For Each objRecip In objMail.Recipients
' check to see if the recip is already in Contacts
strAddress = AddQuote(objRecip.Address)
For i = 1 To 3
strFind = "[Email" & i & "Address] = " & _
strAddress
Set objContact = colContacts.Find(strFind)
If Not objContact Is Nothing Then
Exit For
End If
Next
' if not, add it
If objContact Is Nothing Then
Set objContact = _
Application.CreateItem(olContactItem)
With objContact
.FullName = objRecip.Name
.Email1Address = strAddress
.Save
End With
End If
Set objContact = Nothing
Next
Set objNS = Nothing
Set objContact = Nothing
Set colContacts = Nothing
End Sub
Function AddQuote(MyText) As String
AddQuote = Chr(34) & MyText & Chr(34)
End Function