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 here: " & 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 = "(e-mail address removed)"
.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
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 said:
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!
