Here is the code I have. It is working just fine. It is being called with a
email address being passed.
I would like to find out how to handle multiple address though... example:
; ;

Would it be best to parse these BEFORE the routine, and then call the
addreciptocontacts1 for each address, of should I modify the code for this
routine and have IT parse the addresses? I think the first would be the
BEST, but it would not be quite as flexible.
What would you suggest?

I did want to post this code so that others can use it being called from
other apps and with a passed recipiant. Oviously, somebody would need to
change the offsets etc to make it work for them. Maybe I can set up the
contact info as being passed so that it can be more generic... I am also
thinking to change it so that a para can be passed for the folder name. But
those cahnges are a differant day....

Thnaks
Bruce
------------------

Sub AddRecipToContacts1(objSRecip As String)

Dim strFind As String

Dim strAddress As String

Dim objSMail As Redemption.SafeMailItem

'Dim objSRecip As Redemption.SafeRecipient
Dim objNS As NameSpace
Dim colContacts As Items
Dim objContact As ContactItem
Dim i As Integer
Dim olApp As Outlook.Application

Set olApp = New Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set objFolder = GetFolder("Personal Folders\BPContacts") 'hard coded
folder location
If Not objFolder Is Nothing Then
Set colContacts = objFolder.Items
If Not colContacts Is Nothing Then
Else
MsgBox "colcontacts is empty"
End If
Else
MsgBox "Could not get a MAPIFolder object for Personal
Folders\BPContacts"

End If
strAddress = objSRecip

For i = 1 To 3 ' check all three email addresses!
strFind = "[Email" & i & "Address] = " & AddQuote(strAddress)
'MsgBox strFind
Set objContact = colContacts.Find(strFind)
If Not objContact Is Nothing Then
Exit For
End If
Next



If objContact Is Nothing Then
Set objContact = objFolder.Items.Add(olContactItem)
With objContact
.FirstName = ActiveCell.Offset(0, 1)
.LastName = ActiveCell.Offset(0, 2)
.HomeTelephoneNumber = ActiveCell.Offset(0, 3)
.HomeAddressStreet = ActiveCell.Offset(0, 36)
.HomeAddressCity = ActiveCell.Offset(0, 37)
.HomeAddressState = ActiveCell.Offset(0, 38)
.HomeAddressPostalCode = ActiveCell.Offset(0, 39)
.SelectedMailingAddress = olHome
.Categories = ActiveCell.Offset(0, 27)
.Email1Address = ActiveCell.Offset(0, 4)
.Save
End With
' MsgBox "Added: " & strAddress
Else
End If

' Release varibles...
Set objContact = Nothing
Set objContact = Nothing
Set objSMail = Nothing
'Set objSRecip = Nothing
Set objNS = Nothing
Set colContacts = Nothing
End Sub



"Sue Mosher [MVP]" wrote in message
...
I am not sure what the "For i = 1 To 3" does

Outlook's ContactItem has 3 email address fields. To be thorough, you need
to check for a match in each one.


"BruceJ" wrote in message
news:HhWrb.119774$275.348715@attbi_s53...

Dumb question: If you're building the message from data in an Excel
worksheet, why not use that information (i.e. what you use to set the
value
of To) to create the contact directly?
-----------------------
That was going to be my approch, just one or two things I am not sure
about
in your code.(you can see where I commented it out when I was trying this
out....)
Here is what I have, but I am not sure what the "For i = 1 To 3" does....
also a few other little things.... but this looks like what I need... I
think... I might need to clean up the extra varibles though...


Sub AddRecipToContacts1(objSRecip as string)

Dim strFind As String

Dim strAddress As String

Dim objSMail As Redemption.SafeMailItem

Dim objSRecip As Redemption.SafeRecipient
Dim objNS As NameSpace
Dim colContacts As Items
Dim objContact As ContactItem
Dim i As Integer
Dim olApp As Outlook.Application

' process message recipients

'MsgBox "checking: " & ActiveCell.Offset(0, 1)

' Set objSMail = CreateObject("Redemption.SafeMailItem")

' objMail.Save

' objSMail.Item = objMail

Set olApp = New Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set objFolder = GetFolder("Personal Folders\BPContacts")
If Not objFolder Is Nothing Then
Set colContacts = objFolder.Items
If Not colContacts Is Nothing Then
Else
MsgBox "colcontacts is empty"
End If
Else
MsgBox "Could not get a MAPIFolder object for Personal
Folders\BPContacts"
End If
strAddress = objSRecip
MsgBox strAddress

For i = 1 To 3
strFind = "[Email" & i & "Address] = " & AddQuote(strAddress)
MsgBox strFind
Set objContact = colContacts.Find(strFind)
If Not objContact Is Nothing Then
Exit For
End If
Next



If objContact Is Nothing Then
Set objContact = objFolder.Items.Add(olContactItem)
With objContact
.FirstName = ActiveCell.Offset(0, 1)
.LastName = ActiveCell.Offset(0, 2)
.HomeTelephoneNumber = ActiveCell.Offset(0, 3)
.HomeAddressStreet = ActiveCell.Offset(0, 36)
.HomeAddressCity = ActiveCell.Offset(0, 37)
.HomeAddressState = ActiveCell.Offset(0, 38)
.HomeAddressPostalCode = ActiveCell.Offset(0, 39)
.SelectedMailingAddress = olHome
.Categories = ActiveCell.Offset(0, 27)
'.Email1Address = strAddress
.Email1Address = ActiveCell.Offset(0, 4)
.Save
End With
MsgBox "Added: " & strAddress
Else
End If

' Release varibles...
Set objContact = Nothing
Set objContact = Nothing
Set objSMail = Nothing
Set objSRecip = Nothing
Set objNS = Nothing
Set colContacts = Nothing
End Sub