So we are holding this big event and I have an excel sheet with everyones name, email address as well as their itinerary files (there are 2 of them) Cells(x, 3) and Cells(x, 4). What I am trying to do is go down the column and send everyone a 'personalized' email with all of their information.
In the code, the for loop only goes to 3 because I am just testing it out by sending the emails to myself and don't want to end up getting 1000 emails :P
I keep getting a Run-Time Error 440 (Automation Error) at the lines where I attempt to add the attachments... not sure what's going on or how to remedy it any help is appreciated
Code
Sub CreateHTMLMail()
'Creates a new e-mail item and modifies its properties.
Dim olApp As Object
Dim objMail As Object
Dim body, head, filePath, subject As String
Dim x As Long
Set olApp = CreateObject("Outlook.Application")
'Create e-mail item
Set objMail = olApp.CreateItem(0)
filePath = "\\fileserver\homeshares\Tsee\My Documents\Metropolitan Sales\MNF"
subject = "Important Travel Information for MNF Event this weekend"
x = 1
For x = 1 To 3
head = "<HTML><BODY><P>Hi " & Cells(x, 1).Value & ",</P>"
body = body & "<BR /><P>We are looking forward to having you at our <STRONG>Metropolitan Night Football Event</STRONG> this upcoming Sunday, <STRONG>11/17</STRONG>! Note, that the Giants game time has changed from 8:30 PM to 4:25 PM.</P>"
body = body & "<BR /><P>Please find attached your travel information packet that contains important addresses and confirmation numbers. Please read through it and let me know if you have any questions.</P>"
body = body & "<BR /><P>If you need to reach me this weekend, please call my cell phone <STRONG>(631) 793-9047</STRONG> or email me.</P>"
body = body & "<BR /><P>Thanks,<BR />Liz</P></BODY></HTML>"
With objMail
.subject = subject
.To = Cells(x, 2).Value
.Attachments.Add = filePath & "/" & Cells(x, 3).Value
.Attachments.Add = filePath & "/" & Cells(x, 4).Value
.BodyFormat = olFormatHTML
.HTMLBody = head & body
.Send
End With
Next x
End Sub
Further to the above comments, #bamie9l has already solved one problem of yours
Problem 2
#bamie9l Awesome! That worked, but now at the .BodyFormat = olFormatHTML line I get Run-time error '5': Invalid procedure call or argument – metsales 13 mins ago
You are latebinding with Outlook from Excel and olFormatHTML is an Outlook constant and hence Excel is unable to recognize it. In the Immediate Window of MS-Outlook if you type ?olFormatHTML then you will note that the value of that constant is 2
Hence we have to declare that constant in Excel. Like I mentioned, either you can put Const olFormatHTML = 2 at the top of the code or replace .BodyFormat = olFormatHTML by .BodyFormat = 2
Problem 3
#SiddharthRout So that works, but now I get a crazy automation error... it goes through the loop once.. sends 1 email and then when it gets up to .subject = subject I get Run-time error '-2147221238 (8004010a)': Automation Error which as far as I know is the same as Run-Time Error 440 – metsales
The problem is that you are creating the outlook item outside the loop by
Set objMail = olApp.CreateItem(0)
Outlook already sent that email and now for the next email you will have to re-create it. So move that line inside the loop.
For x = 1 To 3
Set objMail = olApp.CreateItem(0)
head = "<HTML><BODY><P>Hi " & Cells(x, 1).Value & ",</P>"
Body = "Blah Blah"
With objMail
.subject = subject
.To = Cells(x, 2).Value
.Attachments.Add = FilePath & "/" & Cells(x, 3).Value
.Attachments.Add = FilePath & "/" & Cells(x, 4).Value
.BodyFormat = olFormatHTML
.HTMLBody = head & Body
.Send
End With
Next x
Related
I'm working on a mail merge macro and I'm trying to copy the text from my word document including the format in the mail body unfortunately it doesn't accept the range.paste function there.
Looking forward to any advice.
Set oWord = CreateObject("Word.Application")
oWord.Documents.Open FileName:="*\Flightticket.docx", ReadOnly:=True
Set oDoc = oWord.ActiveDocument
Set oRange = ActiveDocument.Range(Start:=0)
oWord.Visible = False
oRange.Copy
*
*
*
With oMail
.To = oContact.Email1Address
.Subject = Left(oDoc.Name, Len(oDoc.Name) - 5) & " " & mText
.GetInspector.Activate 'Signatur
olOldBody = .HTMLBody
'The content of the document is used as the body for the email
.HTMLBody = oRange.Paste & olOldBody 'Here is the error
End With
I now worked around the problem with adding html code to my word document and included the whole content without copy-paste. This worked out pretty good.
.HTMLBody = oDoc.Content & olOldBody
.HTMLBody = oRange.FormattedText & olOldBody
I need to extract outlook emails and name it with part of the sender email address (after "#" and before ".com"). My codes works fine but as for the renaming part, some of the files are not assigned correctly, especially emails within a thread. I had tried searching for solutions for the past 2 weeks, but failed to do so. Would appreciate if anyone could help me out on this issue. Thanks!
[UPDATED]:
Within a thread: It's the running list of all the succeeding replies starting with the original email.
I've wrote codes to extract emails into a designated location and after it is extracted, that email should be named "company's name_datetime received_title of email". Username Suppose to be extracted from sender email address. For example, if I received email from john#companyA.com, subject header is "project" , when I run extraction, the renaming way should be "company A_12-08-2017 09:30AM_Project".
However, with this current code, some of the emails will be named with different company name especially emails in thread. For example, john#companyA.com send an email with title "Project" and I (cheese#companyB.com) replied back and title now becomes "RE:Project". When I run extraction, the email renaming way for the email "Project" is correct, whereas for email "RE:Project", the renaming outcome turns out to be "companyC_datetime received_RE:Project" where Company C does not even exist in that email. (Company C comes from other emails).
Set SubFolder = OutlookApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set MItem = SubFolder.Items(j)
strEmail = Split(SubFolder.Items(j).SenderEmailAddress, "#")(1)
If (InStr(1, strEmail, ".") > 0) Then
strFullName = Split(strEmail, ".")(0)
End If
StrReceived = Format(MItem.ReceivedTime, "dd-mm-yyyy H.MMAMPM")
strSubject = MItem.Subject
'Rename file as Bank name_Date_Title
StrName = StripIllegalChar(strSubject)
StrFile = StrSaveFolder & strFullName & "_" & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
MItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
On Error Resume Next is for expected errors.
I suggest there is an unexpected error, likely when the MItem object is not a mailitem.
If so this line would fail.
strEmail = Split(SubFolder.Items(j).SenderEmailAddress, "#")(1)
Now due to the misuse of On Error Resume Next, you do not have a chance to fix errors. strEmail remains what it was before the error.
Dim MItem as object
If MItem.class = olMail then
So there are several SO questions and Google results that come up under "On Error GoTo executes once" and in just about every case the recommended solution is to add Err.Clear or some forum of Resume to clear the error out. VBA errors can only be handled one at a time, so they need to be cleared.
Having implemented these, as you might have guessed, I am running into this issue where the On Error GoTo is only executing once and I can't figure out why.
Below is my loop. I did leave some code off the top because there is quite a bit of it and it isn't relevant. Mostly user prompts and making arrays. To explain a little what is going on, conos() is an array containing the values of a specific column. Based on a segment of the filename, it searches for the code in the array, to get its index, which corresponds to the row.
If there isn't a Match it triggers the error. That just means there is a file, but no contact to send it to. It should skip to NoContact and create a list of these files.
So with my files, the first has a contact and generates the email, the second does not and skips to NoContact and adds the file to the list. Five more run with contacts and then it gets to another that should go to NoContact, but Unable to get the Match property of the WorksheetFunction class comes up.
It seems the error isn't getting cleared from the first one. Not sure why.
For Each objFile In objFolder.Files
wbName = objFile.Name
' Get the cono along with handling for different extensions
wbName = Replace(wbName, ".xlsx", "")
wbName = Replace(wbName, ".xlsm", "")
wbName = Replace(wbName, ".xls", "")
' Split to get just the cono
fileName() = Split(wbName, "_")
cono = fileName(2)
' Create the cell look up
c = Cells(1, WorksheetFunction.Match("Cono", cols(), 0)).Column
' ******************** ISSUE IS HERE ***************************
On Error GoTo NoContact
r = Cells(WorksheetFunction.Match(cono, conos(), 0), c).Row
Cells(r, c).Select
' Fill the variables
email = Cells(r, c).Offset(0, 1).Value
firstName = Cells(r, c).Offset(0, 3).Value
lastName = Cells(r, c).Offset(0, 4).Value
account = Cells(r, c).Offset(0, -2).Value
username = Cells(r, c).Offset(0, 6).Value
password = Cells(r, c).Offset(0, 7).Value
fPassword = Cells(r, c).Offset(0, 8).Value
' Mark as completed
Cells(r, c).Offset(0, 9).Value = "X"
' Set the object variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Body of the email
str = "Hi " & firstName & "," & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
' Parameters of the email
On Error Resume Next
With OutMail
.To = email
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = str
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
End With
On Error GoTo 0
' Based on the user prompts, whether or not the emails will be sent without checking them first
If finalCheck = vbYes Then
OutMail.Send
Else
OutMail.Display
End If
NoContact:
' Determiine which files don't have a corresponding email and add to list
If email = Empty Then
If conoB <> "" Then
conoB = conoB & ", " & cono
Else
conoB = cono
End If
End If
Err.Clear
' Clear variables for next use
Set OutMail = Nothing
Set OutApp = Nothing
cono = Empty
email = Empty
firstName = Empty
lastName = Empty
account = Empty
username = Empty
password = Empty
fPassword = Empty
Next:
Err.Clear just clears the information regarding the last error from the Err object - it does not exit out of error handling mode.
If an error is detected and your On Error GoTo NoContact is invoked, your code jumps down to the NoContact label, and then finally finds it way back to the start of your For Each objFile In objFolder.Files loop while still in error-handling mode.
If another error occurs while still in error-handling mode, VBA throws the error as it can no longer trap it.
You should structure your code along the lines of
For Each objFile In objFolder.Files
'...
On Error GoTo NoContactError
'...
NoContact:
'...
Next
'...
Exit Sub
NoContactError:
'Error handling goes here if you want it
Resume NoContact
End Sub
But, as Tim Williams, commented - it is much better to avoid situations that require On Error error-handling whenever possible.
I've created a subroutine that grabs all the relevant details and attachments to send out automated emails for me. Here is the code I have:
Sub Mail_workbook_Outlook_1()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim To1 As String, CC1 As String, BCC1 As String, Title1 As String, Body1 As String, Att1 As String
' Create "Other Distribution - In Email" Emails
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
To1 = Cells(8, 2).Value
CC1 = Cells(8, 3).Value
BCC1 = Cells(8, 4).Value
Title1 = Cells(8, 5).Value
Body1 = Cells(8, 6).Value
Att1 = Cells(8, 7).Value
On Error Resume Next
With OutMail
' BodyFormat command makes the email a rich format message allowing us to place attachments within the body of the email instead of in the attachment header
.BodyFormat = olFormatRichText
.To = To1
.CC = CC1
.BCC = BCC1
.Subject = Title1
.Body = Body1
.Attachments.Add Att1, , 10
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
This works fine and inserts my attachment at the end of my email body. The issue is this specific line:
.Attachments.Add Att1, , 10
In this code the "10" is supposed to represent the position of the attachment. I.E. this is supposed to mean that after the first 9 characters in my "Body1" variable, instead of the 10th character the attachment will be placed here. See here: https://msdn.microsoft.com/en-us/library/office/ff869553.aspx
However, for some reason no matter what number I put in the position option it always just puts my attachment at the very end of the email. I need the attachment to be in the middle of several paragraphs so this is causing an issue. Any idea what is causing this?
I should mention I have selected the Microsoft Outlook Object Library from Tools>References.
Any help is greatly appreciated!
So I found out that this is a bug in Outlook 2008/2010 for which there does not seem to be a fix :(
http://argurosblog.blogspot.com/2011/11/how-to-create-task-or-appointment-using.html
Change the content of the body with:
Body1 = "This is the body of the mail, line 1" & vbcrlf
Body1 = Body1 & "This is the second line of text, line 2" & vbcrlf
Body1 = Body1 & "This is the last line of text, line 3."
and run your code.
As you can see the attachment is not placed after the 10.th character, but after the first vbcrlf found after the 10.th character.
If you try with .Attachments.Add Att1, , 50 (in the middle of the second line), it will be placed between line 2 and line 3.
If you delete all the vbcrlfs characters in your body, it will placed at the end of the body, and that is probably what happens to you.
Parse the content of your body and insert vbcrlf ('hard returns') characters where needed.
Hope this helps.
I have some undeliverable emails in a folder. I am trying to go through each email in the folder and pull out the intended recipients email address by searching the message.
I have some VBA code that works on regular emails, but since undeliverable's aren't Outlook "Mail Items", they are Outlook "Report Items", I am having issues searching the message. The search function is coming back empty and after a lot of research, it seems that maybe "Report Items" do not actually have a "body" that can be searched.
The email in all the error reports are in the following format in the report.
(xxxxxx#xxxxxx.com)
Here is the code I am using, which works on normal Mail Items.
Sub Undeliver()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"
'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(I)
'selects the body of the current email being searched
msgtext = myitem.Body
'searches the body for the first open parentheses and first close
'parentheses and copies the value in between into an array
delimtedMessage = Replace(msgtext, "(", "###")
delimtedMessage = Replace(delimtedMessage, ")", "###")
'splits the array up into two pieces
messageArray = Split(delimitedMessage, "###")
'this inputs the values of the array into my excel spreadsheet
xlobj.Range("a" & I + 1).Value = messageArray(1)
xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I
End Sub
Does anyone know how I can access the message part of the report for searching purposes?
The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.
Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.
Hopefully this helps someone in the future!
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True
For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
msgtext = StrConv(myitem.Body, vbUnicode)
delimtedMessage = Replace(msgtext, "mailto:", "###")
delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
messageArray = Split(delimtedMessage, "###")
xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I
xlobj.Application.displayStatusBar = False
Well, there is always this solution.
The gist is that ReportItem.Body returns an unreadable string, so this solution saves the ReportItem as a text file, then parses the text file. Its not exactly elegant, but it should work.
Hope this helps!