Adding senders automatically to contact list

P

Pietro

Hi all,

I'd like to add all the e-mails of those who send me messages
automatically to new contact list,i'm using the below code but unfortunately
it does not work.
Could anybody help?


' The Application_ItemSend procedure must go in the
' built-in ThisOutlookSession session module in Outlook VBA
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
If Item.Class = olMail Then
Call AddRecipToContacts(Item)
End If
Set Item = Nothing
End Sub

' This procedure can go in any module
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

' helper function - put in any module
Function AddQuote(MyText) As String
AddQuote = Chr(34) & MyText & Chr(34)
End Function
 
S

Sue Mosher [MVP-Outlook]

Please be specific about what doesn't work. DOes any VBA code run at all? Have you added a breakpoint and stepped through the code?

FYI, there is a newsgroup specifically for general Outlook programming issues "down the hall" at microsoft.public.outlook.program_vba or, via web interface, at http://www.microsoft.com/office/community/en-us/default.mspx?dg=microsoft.public.outlook.program_vba


--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 
P

Pietro

Thank you for your answer,
It does not work means that i receive messages and the senders are not
added automatically to the contacts,this is the first code i'm trying to run
Please be specific about what doesn't work. DOes any VBA code run at all? Have you added a breakpoint and stepped through the code?

FYI, there is a newsgroup specifically for general Outlook programming issues "down the hall" at microsoft.public.outlook.program_vba or, via web interface, at http://www.microsoft.com/office/community/en-us/default.mspx?dg=microsoft.public.outlook.program_vba


--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers


Pietro said:
Hi all,

I'd like to add all the e-mails of those who send me messages
automatically to new contact list,i'm using the below code but unfortunately
it does not work.
Could anybody help?


' The Application_ItemSend procedure must go in the
' built-in ThisOutlookSession session module in Outlook VBA
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
If Item.Class = olMail Then
Call AddRecipToContacts(Item)
End If
Set Item = Nothing
End Sub

' This procedure can go in any module
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

' helper function - put in any module
Function AddQuote(MyText) As String
AddQuote = Chr(34) & MyText & Chr(34)
End Function
Click to expand...
Click to expand...
 
S

Sue Mosher [MVP-Outlook]

You should make sure you've taking care of the basics of running VBA code. See http://www.outlookcode.com/d/vbabasics.htm

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers


Pietro said:
It does not work means that i receive messages and the senders are not
added automatically to the contacts,this is the first code i'm trying to run
on my Outlook,by the way i don't have good experience in Outlook programming
I'd like to add all the e-mails of those who send me messages
automatically to new contact list,i'm using the below code but unfortunately
it does not work.
Could anybody help?


' The Application_ItemSend procedure must go in the
' built-in ThisOutlookSession session module in Outlook VBA
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
If Item.Class = olMail Then
Call AddRecipToContacts(Item)
End If
Set Item = Nothing
End Sub

' This procedure can go in any module
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

' helper function - put in any module
Function AddQuote(MyText) As String
AddQuote = Chr(34) & MyText & Chr(34)
End Function
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Question abt Outlook 2003 VBA application by Sue Mosher*10152008 6
Problems with code 1
Problems with code 1
Word macro that can call cells out of Excel for a find and replace 0
Making a macro only work on certain files 2
Closing PDF file from Excel VBA (Adobe Reader, Adobe Acrobat, Browser) 0
VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0
VBA Export to PDF 0

Top