Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming,microsoft.public.outlook.configuration,microsoft.public.outlook.General,microsoft.public.outlook.program_vba
|
|||
|
|||
Macros and Outlook?
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! |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macros - Converting Excel spreadheet to Outlook email | Excel Discussion (Misc queries) | |||
custimized outlook today in outlook 2007 | Excel Discussion (Misc queries) | |||
excel open in outlook if outlook is running | Excel Discussion (Misc queries) | |||
Send to Outlook 2000 not Outlook Express | Excel Discussion (Misc queries) | |||
e-mail macros: MS Outlook | Excel Programming |