Forum Discussion
Sending Outlook mail using Excel VBA
Nuts. I had a more detailed answer but I put a link in it and that got it removed as spam. I've asked for it to be restored.
Anyway,
1. Yes
2. Only as a way to get the Excel selection into an email with format retained.
3. Yes, an intermediate editor step ONLY, so that the Excel formatting is not lost. Apparently Outlook VB cannot do that.
[update] We're getting closer. We used SendKeys to tab forward into the body while we were setting the .Subject of the objMail. (Using .Body to add text causes a loss of formatting.) With this change, the macro works all the time EXCEPT when the last created email is open. I find this bizarre but by trial and error we discovered that closing or sending the most-recent email in Outlook allows the macro to succeed even if older Outlook mail windows remain open.
I tried a kludge to open and then close a dummy email within the macro, before creating the desired email. This sadly didn't work. There's something crucial about actually looking at the email in Outlook and then closing it.
Typically SendKeys should be used as a last alternative as it can behave unexpectedly. Ironically, the code that you need to use was also created by Ron De Bruin. It turns a range into HTML. THat way you can just put the HTML in the email rather than having to use MS Word as an intermediary.
Here is the original website link: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Here is his code that I have modified to work for my needs. I believe this should do what you want. If it doesn't work I can look at another project where I did something similar. :
Sub CreateAnHTMLEmail()
'Alter Send Email Sub Procedure Details in order
'To Modify Subject, Recipients...etc...
'The range put in this Sub is....the one that will be
'put into the email... i.e. This puts A1:G21 in the email
Call SendEmail(Sheets("Sheet1").Range("A1:G21"))
End Sub
Sub SendEmail(MyHTMLRng As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim OutlookOpened As Boolean
OutlookOpened = False
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
OutlookOpened = True
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "name@abc.com"
.cc = "fox@test.com; otherperson@test.com"
.Subject = "My Subject Line"
.htmlbody = RangetoHTML(MyHTMLRng)
.Display 'allows email to be displayed and checked before manually sending it
'.Send 'This sends the email
End With
On Error GoTo 0
Set OutMail = Nothing
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
OK, here is the solution that is working. The critical change was to construct the text for the email, including calling the RangeToHtml function, before going to Outlook.
Code prior to this point selects and copies the desired content on the source worksheet.
'Formatted text to go in email before table from Excel
strbody1 = "<span style=font-size:10pt;font-family:Arial; margin-bottom: 0px> Text before table </span>"
'Text to go in email after table
strbody2 = "<span style=font-size:10pt;font-family:Arial; margin-bottom: 0em <br/> Text after table </span>"
Table = RangetoHTML(MyHTMLRng)
Dim OutApp As Object
Dim OutMail As Object
Dim OutlookOpened As Boolean
OutlookOpened = False
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
OutlookOpened = True
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.Subject = "My Subject"
Signature = OutMail.HTMLBody
.HTMLBody = strbody1 & Table & strbody2 & Signature
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(MyHTMLRng)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB, wbName, wbThis As Workbook
Dim rngNew As Range
Dim x As Integer
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Create a new workbook to paste the source table data into
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
' This next bit deletes a blank row in the table if one is found. There cannot be more than one, so the loop exits if one is found.
For myRow = 1 To 100
If Len(.Cells(myRow, 1).Value) < 1 Then
.Cells(myRow, 1).EntireRow.Delete
Exit For
End If
Next
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (False) 'True will replace, rather than insert
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
We've come up with a solution that's working! It's not much different than what is above but different enough I guess, because it's working. I'll post the details after a bit more testing but I wanted to let you know that we can all "stand down" for now.
Code prior to this selects and copies the relevant range in Excel
Dim OutApp As Object
Dim OutMail As Object
Dim OutlookOpened As Boolean
OutlookOpened = False
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
OutlookOpened = True
End If
'Create a dummy email and close it without saving
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Test"
.Close 1
End With
'Text before table
strbody1 = "<BODY style=font-size:10pt;font-family:Arial; margin-bottom: 0em> Some leading text</BODY>"
'Text after table
strbody2 = "<BODY style=font-size:10pt;font-family:Arial; margin-bottom: 0em > <p> Some trailing text </BODY>"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
Signature = OutMail.HTMLBody
.Subject = "My eMail"
.HTMLBody = strbody1 & RangetoHTML(MyHTMLRng) & strbody2 & Signature
End With
On Error GoTo 0
Set OutMail = Nothing
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
End Sub
Function RangetoHTML(MyHTMLRng)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (False) 'False will insert, rather than replace
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Wayne-
Can you please send me your updated VBA code with the RangeToHTML portion incorporated? Specifically the email portion of the code. I believe your issue revolves around the method the code is incorporating the email signature portion (Either way it would be helpful to use the code when testing).
Checking Windows, Excel and Outlook versions now...
Office 2010 on Windows 7
And we have everything working fine content-wise including the user's custom email signature. We're stuck on the open emails problem.
Additional detail: The problem is when the most recently created email is still open. If the last email to be created is closed before the macro runs, I believe it all works fairly reliably.
Wayne-
I can't replicate your issue in the below scenario.
Note my example did not include an email signature.... is this absolutely necessary? Or could you have a text signature like this:
Matt Mickle
X Company
Contact Info.....
etc..
Sad news. My tester finally had time to resume this project, and reports that the code above fails like our earlier efforts. Neither works if another mail document is already open. Both work fine if no other doc is open. We had included a loop to close open documents before this executes, and I believe it solved the problem, but it's not a practical solution given the workflow of the users. It's be a huge nuisance to close a bunch of emails.
On the upside, it was fairly easy to modify the code above to insert the text blocks on either side of the table and to keep the user's email signature block.
I'd be curious to see if you can replicate the open-email doc problem on your end.
Wayne-
Just wanted to follow up and see if you were able to get the macro fixed. If not I'm happy to do some additional troubleshooting.
- Thanks a million for this. We'll look it over and see if we can get it working for us. The approach sounds promising, The Word editor trick was impressive but we just haven't been able to iron out the bugs, In the meanwhile, enjoy the weekend!