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/comm...ok.program_vba
--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx
"Pietro" <(E-Mail Removed)> wrote in message news:8A694EC8-E8ED-405C-9BC5-(E-Mail Removed)...
> 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
>
>
>
Similar Threads
