I'm back....
I THOUGHT this was working fine.... What seems to happen is that I need to
call the AddRecipToContacts routine 2 times (?) in order for it to work. I
am wondering if it is something with how long it is taking for the message
to be built. If I run the routine (UseDefSig) to create my email the first
time, I usually do not get the address to be searched for passed properly.
Then the wrong address gets stuffed into objContact. However if I run
UseDefSig a second time for the same record, it finds (or does not - as
appropiate) the address I am looking for.

It seems when this happens that the straddress is empty.
What I "think" is happening is that the email that is being passed is being
built programically, and your routine is being called before the email is
finished being built, and the address may not physically be in the address
line yet.

Does that make sense?
How can I figure out if that is the case, and if so, how can I work around
this? Is the a way I can just pass the email address to start with?

Thnaks
Bruce



Here is the code that I am using. There are a lot of msgboxes as I was
trying to isolate what was happening.


Sub UseDefSig(FileNAME)
Dim ol As Outlook.Application
Dim mi As MailItem
Dim MyHtm As String
Dim AutoSig As String
Dim TheSig As String
Dim strIn As String
Dim FNum As Long
FileNAME = "c:\scripts\" & FileNAME
FNum = FreeFile
Open FileNAME For Input As FNum

Do While Not EOF(FNum)
Line Input #FNum, strIn
TheSig = TheSig & vbCrLf & strIn
Loop
Close FNum
Set ol = New Outlook.Application
Set mi = ol.CreateItem(olMailItem)
mi.Display
MyHtm = mi.HTMLBody ' or MyHtm = TheSig
MyHtm = "<font size=""4""<font color=""blue""<b<font face=""Comic Sans
MS"""
MyHtm = MyHtm & "Hi " & ActiveCell.Offset(0, 1).Value & ","
MyHtm = MyHtm & "</font</b</font" & TheSig
mi.To = ActiveCell.Offset(0, 4)
mi.HTMLBody = MyHtm
mi.ReadReceiptRequested = True
mi.OriginatorDeliveryReportRequested = True
mi.Subject = ActiveCell.Offset(0, 1) & ", " &
ThisWorkbook.Sheets("Scripts").Range("b80").Value
Call AddRecipToContacts(mi)

'Call AddRecipToContacts(ActiveCell.Offset(0, 4))


End Sub




Sub AddRecipToContacts(objMail As MailItem)
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 olNs = olApp.GetNamespace("MAPI")
Set objNS = olApp.GetNamespace("MAPI")
'Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set objFolder = GetFolder("Personal Folders\BPContacts")
If Not objFolder Is Nothing Then
Set colContacts = objFolder.Items
' MsgBox "Got info for Personal Folders\BPContacts"
If Not colContacts Is Nothing Then
' MsgBox "colcontacts has value"
Else
MsgBox "colcontacts is empty"
' Stop
End If
Else

MsgBox "Could not get a MAPIFolder object for Personal
Folders\BPContacts"

End If

For Each objSRecip In objSMail.Recipients
' check to see if the recip is already in Contacts
strAddress = objSRecip.Address
MsgBox strAddress

For i = 1 To 3
strFind = "[Email" & i & "Address] = " & AddQuote(strAddress)
MsgBox strFind

Set objContact = colContacts.Find(strFind)
'Stop
MsgBox "Up he " & objContact
If Not objContact Is Nothing Then
Exit For
End If
Next

If objContact Is Nothing Then
' MsgBox "Adding ..."
' msgstr = "Adding: " & ActiveCell.Offset(0, 1) &
ActiveCell.Offset(0, 2) & strAddress
Set objContact = objFolder.Items.Add(olContactItem)
'Set objContact = Application.CreateItem(olContactItem)
With objContact
'.FullName = objSRecip.Name
.FirstName = ActiveCell.Offset(0, 1)
.LastName = ActiveCell.Offset(0, 2)
.HomeTelephoneNumber = ActiveCell.Offset(0, 3)
'.Email1Address = "
.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
MsgBox "is this the problem:" & objContact
End If
'MsgBox "is this the problem:" & objContact

Set objContact = Nothing
Next


Set objContact = Nothing
Set objSMail = Nothing

Set objSRecip = Nothing

Set objNS = 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

Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like

' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Dim colFolders As Outlook.Folders

Dim objFolder As Outlook.MAPIFolder

Dim arrFolders() As String

Dim i As Long
'MsgBox ("Here I Am")
On Error Resume Next



strFolderPath = Replace(strFolderPath, "/", "\")

arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")

Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = objNS.Folders.Item(arrFolders(0))
'MsgBox (t)

If Not objFolder Is Nothing Then

For i = 1 To UBound(arrFolders)

Set colFolders = objFolder.Folders

Set objFolder = Nothing

Set objFolder = colFolders.Item(arrFolders(i))

If objFolder Is Nothing Then
MsgBox ("exit")
Exit For

End If

Next

End If
'MsgBox ("down here")
' MsgBox (GetFolder)

'Stop

Set GetFolder = objFolder
'MsgBox (GetFolder)
Set colFolders = Nothing

Set objNS = Nothing

Set objApp = Nothing

End Function










"Sue Mosher [MVP]" wrote in message
...
That's it, all right. When in doubt about property names, check the object
browser: Press ALt+F11 to open the VBA environment in Outlook, then press
F2.

--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx


"BruceJ" wrote in message
news:gMUqb.102111$275.280736@attbi_s53...
I figured it out! I am using
Set objContact = objFolder.Items.Add(olContactItem)
Now... I just need to figure out the name for the fields and stuff those
with the info I need!

I think you've diagnosed this correctly: The recipients in the outgoing message must be resolved first, and that hasn't happened yet when you make your first pass. The most direct solution is to do Recipients.ResolveAll, but you'll need to use Redemption for this to avoid security prompts.

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?

--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx


"BruceJ" wrote in message news:WbUrb.120261$9E1.592233@attbi_s52...
I'm back....
I THOUGHT this was working fine.... What seems to happen is that I need to
call the AddRecipToContacts routine 2 times (?) in order for it to work. I
am wondering if it is something with how long it is taking for the message
to be built. If I run the routine (UseDefSig) to create my email the first
time, I usually do not get the address to be searched for passed properly.
Then the wrong address gets stuffed into objContact. However if I run
UseDefSig a second time for the same record, it finds (or does not - as
appropiate) the address I am looking for.

It seems when this happens that the straddress is empty.
What I "think" is happening is that the email that is being passed is being
built programically, and your routine is being called before the email is
finished being built, and the address may not physically be in the address
line yet.

Does that make sense?
How can I figure out if that is the case, and if so, how can I work around
this? Is the a way I can just pass the email address to start with?

Thnaks
Bruce



Here is the code that I am using. There are a lot of msgboxes as I was
trying to isolate what was happening.


Sub UseDefSig(FileNAME)
Dim ol As Outlook.Application
Dim mi As MailItem
Dim MyHtm As String
Dim AutoSig As String
Dim TheSig As String
Dim strIn As String
Dim FNum As Long
FileNAME = "c:\scripts\" & FileNAME
FNum = FreeFile
Open FileNAME For Input As FNum

Do While Not EOF(FNum)
Line Input #FNum, strIn
TheSig = TheSig & vbCrLf & strIn
Loop
Close FNum
Set ol = New Outlook.Application
Set mi = ol.CreateItem(olMailItem)
mi.Display
MyHtm = mi.HTMLBody ' or MyHtm = TheSig
MyHtm = "<font size=""4""<font color=""blue""<b<font face=""Comic Sans
MS"""
MyHtm = MyHtm & "Hi " & ActiveCell.Offset(0, 1).Value & ","
MyHtm = MyHtm & "</font</b</font" & TheSig
mi.To = ActiveCell.Offset(0, 4)
mi.HTMLBody = MyHtm
mi.ReadReceiptRequested = True
mi.OriginatorDeliveryReportRequested = True
mi.Subject = ActiveCell.Offset(0, 1) & ", " &
ThisWorkbook.Sheets("Scripts").Range("b80").Value
Call AddRecipToContacts(mi)

'Call AddRecipToContacts(ActiveCell.Offset(0, 4))


End Sub




Sub AddRecipToContacts(objMail As MailItem)
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 olNs = olApp.GetNamespace("MAPI")
Set objNS = olApp.GetNamespace("MAPI")
'Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set objFolder = GetFolder("Personal Folders\BPContacts")
If Not objFolder Is Nothing Then
Set colContacts = objFolder.Items
' MsgBox "Got info for Personal Folders\BPContacts"
If Not colContacts Is Nothing Then
' MsgBox "colcontacts has value"
Else
MsgBox "colcontacts is empty"
' Stop
End If
Else

MsgBox "Could not get a MAPIFolder object for Personal
Folders\BPContacts"

End If

For Each objSRecip In objSMail.Recipients
' check to see if the recip is already in Contacts
strAddress = objSRecip.Address
MsgBox strAddress

For i = 1 To 3
strFind = "[Email" & i & "Address] = " & AddQuote(strAddress)
MsgBox strFind

Set objContact = colContacts.Find(strFind)
'Stop
MsgBox "Up he " & objContact
If Not objContact Is Nothing Then
Exit For
End If
Next

If objContact Is Nothing Then
' MsgBox "Adding ..."
' msgstr = "Adding: " & ActiveCell.Offset(0, 1) &
ActiveCell.Offset(0, 2) & strAddress
Set objContact = objFolder.Items.Add(olContactItem)
'Set objContact = Application.CreateItem(olContactItem)
With objContact
'.FullName = objSRecip.Name
.FirstName = ActiveCell.Offset(0, 1)
.LastName = ActiveCell.Offset(0, 2)
.HomeTelephoneNumber = ActiveCell.Offset(0, 3)
'.Email1Address = "
.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
MsgBox "is this the problem:" & objContact
End If
'MsgBox "is this the problem:" & objContact

Set objContact = Nothing
Next


Set objContact = Nothing
Set objSMail = Nothing

Set objSRecip = Nothing

Set objNS = 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

Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like

' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Dim colFolders As Outlook.Folders

Dim objFolder As Outlook.MAPIFolder

Dim arrFolders() As String

Dim i As Long
'MsgBox ("Here I Am")
On Error Resume Next



strFolderPath = Replace(strFolderPath, "/", "\")

arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")

Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = objNS.Folders.Item(arrFolders(0))
'MsgBox (t)

If Not objFolder Is Nothing Then

For i = 1 To UBound(arrFolders)

Set colFolders = objFolder.Folders

Set objFolder = Nothing

Set objFolder = colFolders.Item(arrFolders(i))

If objFolder Is Nothing Then
MsgBox ("exit")
Exit For

End If

Next

End If
'MsgBox ("down here")
' MsgBox (GetFolder)

'Stop

Set GetFolder = objFolder
'MsgBox (GetFolder)
Set colFolders = Nothing

Set objNS = Nothing

Set objApp = Nothing

End Function










"Sue Mosher [MVP]" wrote in message
...
That's it, all right. When in doubt about property names, check the object
browser: Press ALt+F11 to open the VBA environment in Outlook, then press
F2.

--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx


"BruceJ" wrote in message
news:gMUqb.102111$275.280736@attbi_s53...
I figured it out! I am using
Set objContact = objFolder.Items.Add(olContactItem)
Now... I just need to figure out the name for the fields and stuff those
with the info I need!

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








--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx


"BruceJ" wrote in message
news:WbUrb.120261$9E1.592233@attbi_s52...
I'm back....
I THOUGHT this was working fine.... What seems to happen is that I need to
call the AddRecipToContacts routine 2 times (?) in order for it to work. I
am wondering if it is something with how long it is taking for the message
to be built. If I run the routine (UseDefSig) to create my email the
first
time, I usually do not get the address to be searched for passed properly.
Then the wrong address gets stuffed into objContact. However if I run
UseDefSig a second time for the same record, it finds (or does not - as
appropiate) the address I am looking for.

It seems when this happens that the straddress is empty.
What I "think" is happening is that the email that is being passed is
being
built programically, and your routine is being called before the email is
finished being built, and the address may not physically be in the address
line yet.

Does that make sense?
How can I figure out if that is the case, and if so, how can I work around
this? Is the a way I can just pass the email address to start with?

Thnaks
Bruce



Here is the code that I am using. There are a lot of msgboxes as I was
trying to isolate what was happening.


Sub UseDefSig(FileNAME)
Dim ol As Outlook.Application
Dim mi As MailItem
Dim MyHtm As String
Dim AutoSig As String
Dim TheSig As String
Dim strIn As String
Dim FNum As Long
FileNAME = "c:\scripts\" & FileNAME
FNum = FreeFile
Open FileNAME For Input As FNum

Do While Not EOF(FNum)
Line Input #FNum, strIn
TheSig = TheSig & vbCrLf & strIn
Loop
Close FNum
Set ol = New Outlook.Application
Set mi = ol.CreateItem(olMailItem)
mi.Display
MyHtm = mi.HTMLBody ' or MyHtm = TheSig
MyHtm = "<font size=""4""<font color=""blue""<b<font face=""Comic Sans
MS"""
MyHtm = MyHtm & "Hi " & ActiveCell.Offset(0, 1).Value & ","
MyHtm = MyHtm & "</font</b</font" & TheSig
mi.To = ActiveCell.Offset(0, 4)
mi.HTMLBody = MyHtm
mi.ReadReceiptRequested = True
mi.OriginatorDeliveryReportRequested = True
mi.Subject = ActiveCell.Offset(0, 1) & ", " &
ThisWorkbook.Sheets("Scripts").Range("b80").Value
Call AddRecipToContacts(mi)

'Call AddRecipToContacts(ActiveCell.Offset(0, 4))


End Sub




Sub AddRecipToContacts(objMail As MailItem)
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 olNs = olApp.GetNamespace("MAPI")
Set objNS = olApp.GetNamespace("MAPI")
'Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
Set objFolder = GetFolder("Personal Folders\BPContacts")
If Not objFolder Is Nothing Then
Set colContacts = objFolder.Items
' MsgBox "Got info for Personal Folders\BPContacts"
If Not colContacts Is Nothing Then
' MsgBox "colcontacts has value"
Else
MsgBox "colcontacts is empty"
' Stop
End If
Else

MsgBox "Could not get a MAPIFolder object for Personal
Folders\BPContacts"

End If

For Each objSRecip In objSMail.Recipients
' check to see if the recip is already in Contacts
strAddress = objSRecip.Address
MsgBox strAddress

For i = 1 To 3
strFind = "[Email" & i & "Address] = " & AddQuote(strAddress)
MsgBox strFind

Set objContact = colContacts.Find(strFind)
'Stop
MsgBox "Up he " & objContact
If Not objContact Is Nothing Then
Exit For
End If
Next

If objContact Is Nothing Then
' MsgBox "Adding ..."
' msgstr = "Adding: " & ActiveCell.Offset(0, 1) &
ActiveCell.Offset(0, 2) & strAddress
Set objContact = objFolder.Items.Add(olContactItem)
'Set objContact = Application.CreateItem(olContactItem)
With objContact
'.FullName = objSRecip.Name
.FirstName = ActiveCell.Offset(0, 1)
.LastName = ActiveCell.Offset(0, 2)
.HomeTelephoneNumber = ActiveCell.Offset(0, 3)
'.Email1Address = "
.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
MsgBox "is this the problem:" & objContact
End If
'MsgBox "is this the problem:" & objContact

Set objContact = Nothing
Next


Set objContact = Nothing
Set objSMail = Nothing

Set objSRecip = Nothing

Set objNS = 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

Public Function GetFolder(strFolderPath As String) As MAPIFolder

' folder path needs to be something like

' "Public Folders\All Public Folders\Company\Sales"

Dim objApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Dim colFolders As Outlook.Folders

Dim objFolder As Outlook.MAPIFolder

Dim arrFolders() As String

Dim i As Long
'MsgBox ("Here I Am")
On Error Resume Next



strFolderPath = Replace(strFolderPath, "/", "\")

arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")

Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = objNS.Folders.Item(arrFolders(0))
'MsgBox (t)

If Not objFolder Is Nothing Then

For i = 1 To UBound(arrFolders)

Set colFolders = objFolder.Folders

Set objFolder = Nothing

Set objFolder = colFolders.Item(arrFolders(i))

If objFolder Is Nothing Then
MsgBox ("exit")
Exit For

End If

Next

End If
'MsgBox ("down here")
' MsgBox (GetFolder)

'Stop

Set GetFolder = objFolder
'MsgBox (GetFolder)
Set colFolders = Nothing

Set objNS = Nothing

Set objApp = Nothing

End Function










"Sue Mosher [MVP]" wrote in message
...
That's it, all right. When in doubt about property names, check the object
browser: Press ALt+F11 to open the VBA environment in Outlook, then press
F2.

--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx


"BruceJ" wrote in message
news:gMUqb.102111$275.280736@attbi_s53...
I figured it out! I am using
Set objContact = objFolder.Items.Add(olContactItem)
Now... I just need to figure out the name for the fields and stuff
those
with the info I need!

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

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

I would keep it modular, which really is the most flexible approach. Parse the recipients and call your AddRecipToContacts1 sub for each one.

FWIW, I never use ActiveCell.Offset in my Excel code. I always use Worksheet.Cells(rownum, colnum). Is there an advantage to ActiveCell.Offset?

--
Sue Mosher, Outlook MVP
Outlook and Exchange solutions at http://www.slipstick.com
Author of
Microsoft Outlook Programming: Jumpstart
for Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

"BruceJ" wrote in message news:TU8vb.256132$HS4.2306534@attbi_s01...
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?

Sue

FWIW, I never use ActiveCell.Offset in my Excel code. I always use
Worksheet.Cells(rownum,
colnum). Is there an advantage to ActiveCell.Offset?

No real advantage that I know. It's just two different way of pointing to
the same Range object. I use Offset because (to me) it's easier to read.

ActiveCell.Offset(1,1).Value

vs.

ActiveSheet.Cells(ActiveCell.Row+1,ActiveCell.Colu mn+1).Value

But it's all a matter of personal preference.

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

The advantage I find is if you have a dynamically changing sheet you can
always track where you are.


For example if you have a sheet that has a table section for equipment and
another table section below that for labour, you can create two named ranges
which indicates the first cell of each of these tables. Now if you need to
add equipment from a separate data source, but you don't know how many lines
will be added, you can create code that loops through the data to be added
and does a row insert one at a time and adds the data at that time. Now if
you need to add the labour from a separate source, instead of needing to
know how many rows were added, so that you know specifically which row to
start inserting. You do this by using the named range and an offset for the
labour section. This works because as you insert rows the named range
addresses accomodate the inserts and or deletions.

SM


"Dick Kusleika" wrote in message
...
Sue

FWIW, I never use ActiveCell.Offset in my Excel code. I always use
Worksheet.Cells(rownum,
colnum). Is there an advantage to ActiveCell.Offset?

No real advantage that I know. It's just two different way of pointing to
the same Range object. I use Offset because (to me) it's easier to read.

ActiveCell.Offset(1,1).Value

vs.

ActiveSheet.Cells(ActiveCell.Row+1,ActiveCell.Colu mn+1).Value

But it's all a matter of personal preference.

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

Thanks Dick!
It is the only way I knew how to do it... is my answer! I now know there is
a different way!
Since I have been using offset, I think I will stay with it!

Bruce

"Dick Kusleika" wrote in message
...
Sue

FWIW, I never use ActiveCell.Offset in my Excel code. I always use
Worksheet.Cells(rownum,
colnum). Is there an advantage to ActiveCell.Offset?

No real advantage that I know. It's just two different way of pointing to
the same Range object. I use Offset because (to me) it's easier to read.

ActiveCell.Offset(1,1).Value

vs.

ActiveSheet.Cells(ActiveCell.Row+1,ActiveCell.Colu mn+1).Value

But it's all a matter of personal preference.

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.