I am trying to add a formatted value, from Excel to an appointment in Outlook, based on:
HTMLBody Workaround For OlAppointment Object?
I get the following error:
"Run-time error '287': Application-defined or object-defined error"
I also need to create a hyperlink in an appointment, using link in one cell and text I want to be visible in another.
Sub MakeApptWithRangeBody()
Dim olApp As Outlook.Application
Dim olApt As Outlook.AppointmentItem
Const wdPASTERTF As Long = 1
Set olApp = Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = Now + 1
.End = Now + 1.2
.Subject = "Test Appointment"
.Location = 18
'Sheet1.ListObjects(1).Range.Copy
ThisWorkbook.Worksheets("Sheet1").Range("D2").Copy
.Display
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With
End Sub
I think you are getting this error because of security settings in Outlook which is generally controlled by the IT Administrators in any organization if you are using an official Outlook Email account
you could try below
.Body = ThisWorkbook.Worksheets("Sheet1").Range("D2").Value
in place of
ThisWorkbook.Worksheets("Sheet1").Range("D2").Copy
and remove the below line
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
You also need to activate the "Microsoft Word Object Library" in the references. Outlook is using Word as editor and this line of code
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
is using Word VBA code (in the editor). So you need the Word reference too not only the one for Outlook.
To create a hyperlink you can check the Hyperlinks.Add method which should work (not tested):
With olApt
.Start = Now + 1
.End = Now + 1.2
.Subject = "Test Appointment"
.Location = 18
'Sheet1.ListObjects(1).Range.Copy
ThisWorkbook.Worksheets("Sheet1").Range("D2").Copy
.Display
Dim Sel As Object
Set Sel = .GetInspector.WordEditor.Windows(1).Selection
Sel.PasteAndFormat wdPASTERTF
Sel.Hyperlinks.Add Anchor:=Sel.Range, Address:="http:\\www.microsoft.com"
End With
Related
I am working on an excel macro to send a series of emails each with a unique attachment, and one of three template emails that are saved as word documents. Everything is working well, except pulling the body of the email in from the word document. The problem seems to be with WordEditor. I get the following error
Err.Description:The operation failed.
Err.Number:-2147467259
Err.Source:Microsoft Outlook
Here is the code I have tried:
Sub SendDCLEmails()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim DCLFile As String 'Attachment that differs for each email
Dim DCLCount As Integer 'Number of emails that will be sent
Dim toList As String
Dim ccList As String
Dim CoverLetter As String 'Word document template email
Dim fileCheckDCL As String
Dim fileCheckCover As String
Dim editor As Object
'Set references to Outlook
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutlookApp = New Outlook.Application
On Error GoTo 0
'Set references to Word
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err <> 0 Then Set WordApp = New Word.Application
On Error GoTo 0
Sheets("Contacts").Select
'Create email for each record on "Contacts" tab
DCLCount = ActiveSheet.UsedRange.Rows.Count - 1
For i = 1 To DCLCount
DCLFile = Range("AD1").Offset(i, 0).Value & "\" & Range("AE1").Offset(i, 0).Value
CoverLetter = Range("AF1").Offset(i, 0).Value
fileCheckDCL = Dir(DCLFile)
fileCheckCover = Dir(CoverLetter)
'Run some validations and generate the toList and ccList variables.
Set WordDoc = WordApp.Documents.Open(CoverLetter)
WordDoc.Content.Copy
'Create Emails
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Display
.To = toList
.CC = ccList
.Subject = Range("AG1").Offset(i, 0).Value
Set editor = .GetInspector.WordEditor 'This is where the error occurs.
editor.Content.Paste
.Attachments.Add DCLFile
.Send
End With
WordDoc.Close savechanges:=False
End If
toList = vbNullString
ccList = vbNullString
CoverLetter = vbNullString
DCLFile = vbNullString
fileCheckDCL = vbNullString
fileCheckCover = vbNullString
Set editor = Nothing
Next i
OutlookApp.Quit
WordApp.Quit
End Sub
There is no need to use late and early-binding technologies in the VBA macros:
Set OutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutlookApp = New Outlook.Application
Instead, you need to use one or another. Read more about that in the Using early binding and late binding in Automation article. I'd suggest declaring all objects with real classes (early-binding), it may allow avoiding mistakes with syntax further. And use the New operator in the code instead of CreateObject one.
Set editor = .GetInspector.WordEditor 'This is where the error occurs.
Calling the WordEditor property may sometimes fail if the Inspector is not yet visible and initialized. Try to call the Display method prior getting the Word editor value.
Also instead of relying on Word documents as templates you may create templates in Outlook and use the Application.CreateItemFromTemplate method which creates a new Microsoft Outlook item from an Outlook template (.oft) and returns the new item. Read more about that in the article which I wrote for the technical blog, see How To: Create a new Outlook message based on a template.
The code works. Outlook crashes for large data.
Turning off .Display may solve the crash problem.
Disabling .Display does not allow Word content to be copied to Outlook body.
Is there any other way, Word content will be copied to email body with .Display turned off? Emails will be generated in the background.
Sample Excel Photo
Sub WordContent_to_EmailBody()
'On Error Resume Next
Dim o As Outlook.Application
Set o = New Outlook.Application
Dim omail As Outlook.MailItem
Dim wd As Word.Application
Dim doc As Word.Document
Set wd = New Word.Application
wd.Visible = True
' *Word Document Template File getting pulled from cell reference*
Set doc = wd.Documents.Open(Cells(1, 2).Value)
Dim i As Long
For i = 4 To 7 ' *Large data loop 4 To 1004 then outlook crashes at 100+*
Set omail = o.CreateItem(olMailItem)
With wd.Selection.Find
.Text = "<<Client>>"
.Replacement.Text = Sheet1.Cells(i, 1).Value
.Execute Replace:=wdReplaceAll
End With
With wd.Selection.Find
.Text = "<<Remarks>>"
.Replacement.Text = Sheet1.Cells(i, 2).Value
.Execute Replace:=wdReplaceAll
End With
doc.Content.Copy ' *Full Word Document Content copied for outlook body*
'Want to turn off `.display` because it crashes outlook for more than 100+
' emails with attachment size more than 500kb. On the other hand, without
' `.display` Word content copy paste dose not work
With omail
.Display
.To = Cells(i, 3).Value
.CC = Cells(i, 4).Value
.Subject = Cells(i, 5).Value
.Attachments.Add Cells(i, 6).Value
Set Editor = .GetInspector.WordEditor
Editor.Content.Paste
.Send ' *Word Content getting Paste to email body and being sent*
End With
Documents("Survey_Outlook.docx").Undo 2
Next i
doc.Close saveChanges:=False
MsgBox "Finish - Check the Generated email in Outlook - OUTBOX FOLDER > Offline Work <"
End Sub
I'd suggest using the HTMLBody property without involving the Word object model for setting up the message bodies. You can construct the HTML markup based on the Office documents on your own and then just set the single property - HTMLBody. That doesn't require the Display method to be used before submitting items.
Also you may consider using a low-level API on which Outlook is built on - Extended MAPI or just any other wrappers around that API such as Redemption.
I am trying to copy all of content of a word doc into a Outlook email body while keeping the format and was looking to follow the solution found on this post but am getting an error on the following line: .BodyFormat = olFormatRichText. When the error handler is removed, I get RTE5: Invalid procedure call or argument
Any idea why this line is throwing an error or how to correct?
Sub Sender(Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim wd As Object
Dim editor As Object
Dim doc As Object
Dim fp As String
fp = "C:\Users\urdearboy\"
Set wd = CreateObject("Word.Application")
Set doc = wd.documents.Open(fp & "mydearfile.docx")
doc.Content.Copy
doc.Close
Set wd = Nothing
On Error GoTo BNP:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "urdearboy#so.com"
.to = Target.Offset(, 2)
.Subject = "Hi Mom"
.BodyFormat = olFormatRichText '<----- ERROR LINE
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.Display
'.Send
Target.Offset(, -1) = "Sent"
End With
BNP:
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Context: I decided to go with the Word to Outlook copy because the file has a lot of formatting and photos and getting the right format strictly in Outlook HTML sounds like a nightmare. If done manually, this would essentially be a complete CTRL + A + Copy from word and CTRL + V in Outlook which keeps all formatting, photos, and gifs with correct format. The goal here is to mimic that process in VBA. If there is a better solution, open to thoughts there as well
If you're late-binding, then add:
Const olFormatRichText As Long = 3
(seems like you didn't have Option Explicit on too...)
You can find the appropriate value of olFormatRichText here.
Can I use mailitem.entryID in Excel VBA?
I have a tool using excel where I can send an outlook email to recipients using spreadsheet as the UI to display user data. I need to store the entryID of each of the emails send to the user in the excel table. Can I set in the code (excel vba) mailitem.entryID = worksheet.cells().value ? Will it retrieve the entryID? Can you give me your input regarding this? Thank you for your help.
Dim AppOutlook As Object
Dim MailOutlook As Object
Dim Emailto, ccto, sendfrom As String
Set AppOutlook = CreateObject("Outlook.Application")
Set MailOutlook =AppOutlook.CreateItem(0)
Emailto = worksheet.Cells().Value
ccto = worksheet.Cells().Value
sendfrom = "email"
With OutMail
.SentOnBehalfOfName = sendfrom
.To = Emailto
.CC = ccto
.BCC = ""
.Subject =
.BodyFormat = olFormatHTML
.HTMLBody = "body here"
.Send
This is my code, and I plan to add the code worksheet.cells.value = MailOutlook.entryID at the last line of the code. Is it possible? and where to add the AddItem event?
You can read the EntryID property after the message is sent. You cannot do that before or immediately after sending the message - it will be changed when the message is asynchronously sent and moved to the Sent Item folder. The erliest you can access the entry id in the Sent Items folder is when the Items.ItemAdd event fires in the Sent Items folder.
The mail item may not exist any longer after calling the Send method. It can be moved to the Outbox folder for further processing by the transport provide. Item can be marked for processing by the transport provider, not being yet sent. So, we need to handle the ItemSend event in the code.
If you need to be sure that the mail item was sent for sure I'd recommend handling the ItemAdd event of the Items class (see the corresponding property of the Folder class). For example, when an Outlook item is sent, a sent copy is placed to the Sent Items folder in Outlook. You may handle the ItemAdd event for that folder to be sure that the item was sent for sure. Consider adding a user property before displaying the Outlook item and checking it in the ItemAdd event handler to identify the item uniquely.
Demo code based on your code:
Sub Test3()
Dim AppOutlook As Object
Dim MailOutlook As Object
Dim Emailto, ccto, sendfrom As String
Set AppOutlook = CreateObject("Outlook.Application")
Set MailOutlook = AppOutlook.CreateItem(0)
Emailto = Worksheets("Sheet3").Cells(1, 1).Value
ccto = Worksheets("Sheet3").Cells(2, 1).Value
sendfrom = "test#outlook.com"
With MailOutlook
.SentOnBehalfOfName = sendfrom
.To = Emailto
.CC = ccto
.BCC = ""
.Subject = "Test"
.BodyFormat = olFormatHTML
.HTMLBody = "body here"
'.Display
.Send
End With
End Sub
Some ItemAdd snippet for you reference(The current event is not the right one, we still need to test it):
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
‘Private Sub Application_Startup()
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim objWatchFolder As Outlook.Folder
Dim AppOutlook As Object
Set AppOutlook = CreateObject("Outlook.Application")
Set objNS = AppOutlook.GetNamespace("MAPI")
'Set the folder and items to watch:
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
' Your code goes here
MsgBox "Message subject: " & Item.Subject & vbcrlf & "Message sender: " & Item.SenderName &" (" & Item.SenderEmailAddress & ")"
Worksheets("Sheet3").Cells(3, 1).Value = Item.EntryID
Set Item = Nothing
End Sub
The MailItem object is part of Outlook's VBA Object library. You can see the documentation for the MailItem object on MSDN here.
To use VBA objects from a different program in Microsoft Office (eg. calling Outlook from Excel, calling Visio from Word, calling Excel from Powerpoint) you first need to make sure you have the right References selected in your Visual Basic Editor (VBE).
How to turn on Outlook references in Excel:
In Excel's VBE, go to Tools > References.
A References - VBAProject box will appear.
Under Available References: scroll down until you reach something like Microsoft Outlook 16.0 Object Library (This will differ depending on the version of Office you are using)
Tick the box and press OK.
Now the Outlook Object references have been enabled, you should be able to call Outlook objects and methods from Excel, including MailItem.
I am trying to create three Outlook appointments in a specific (shared) calendar.
The events will be all-day events. I want the dates for the current row to be added to the calendar. All three dates will be in the same row on the spreadsheet.
The code creates the appointment but the for loop is not working. The only event that is created is the last date.
Sub Makeapt()
Set myOutlook = CreateObject("Outlook.Application")
Set myApt = myOutlook.createitem(1)
Dim i As Integer
For i = 3 To 5
myApt.Subject = Cells(ActiveCell.Row, 1).Value
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
I solved the problem. Appt still goes to the default calendar, but that is actually preferable.
Sub Makeapt()
Dim warning
warning = MsgBox("You are about to create Outlook appointments for subject #" & Cells(ActiveCell.Row, 3) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub
Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 3)
Dim i As Integer
For i = 7 To 9
Set myApt = myOutlook.createitem(1)
myApt.Subject = "Subject #" & ID
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
Dmitry nailed it for how to create an appointment/meeting in a shared calendar from Excel. His post was a big help to me as it seems there are not any very good answers to how to create an appointment on a shared calendar. I looked all over numerous forums to get answers and came up with very little. Based on his answer, I was able to get it working. Below is an example script I put together. This is a somewhat stripped-down version of what I am using for my needs, but I did test this example and it works. Just make sure the Outlook library is selected in the Excel VBA editor's Tools->References menu item.
Sub SendInvitationAsUser()
Rcpts = "user#test.com; user2#test.com, etc#test.com" ' These can be in other formats that Outlook understands like display name.
Subject = "Meeting sent from shared calendar"
' Creates Outlook instance
Set OutApp = CreateObject("Outlook.Application")
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim objfolder As Outlook.Folder
Set myNamespace = OutApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Smith, John Q") 'The invite will come from this user's mailbox
myRecipient.Resolve
If myRecipient.Resolved Then
Set objfolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 'Sets folder where appt will be created
Else
ok = MsgBox("Unable to resolve the name of the sender.", vbCritical, "Error")
Exit Sub
End If
Set OutlookAppt = objfolder.Items.Add(olAppointmentItem) 'Creates appointment in shared calendar
' Edit Outlook appointment, convert to meeting invitation by adding recipients.
With OutlookAppt
.MeetingStatus = olMeeting
.Subject = Subject
.Start = #1/1/2018 8:00:00 AM#
.End = #1/1/2018 9:00:00 AM#
.Location = "Conference Room 1"
.RequiredAttendees = Rcpts
End With
'Use Word to do fancy formatting of body text. Example below is basic but a lot of formatting via VBA is possible.
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
Set DocSelection = WordApp.Selection
WordApp.Visible = True
WordDoc.Activate ' You want to see the window, right?
DocSelection.Font.Name = "Arial" ' Everything is Arial.
DocSelection.Font.Size = "10" ' Everything is size 10.
DocSelection.ParagraphFormat.SpaceAfter = "0" ' No line spacing.
DocSelection.ParagraphFormat.SpaceBefore = "0" ' No line spacing.
DocSelection.TypeText ("Please plan to attend my meeting.")
WordDoc.Content.Copy
OutlookAppt.Display
Set TargetApptDoc = OutlookAppt.GetInspector.WordEditor
TargetApptDoc.Range(0, 0).Paste
WordDoc.Close savechanges:=False
WordApp.Quit
End Sub
If you want a shared calendar, create a recipient object using Application.CreateRecipient, open the shared calendar using Application.Session.GetSharedDefaultFolder, create an appointment using MAPIFolder.Items.Add.