May 24 2018
07:41 AM
- last edited on
Jul 25 2018
10:01 AM
by
TechCommunityAP
May 24 2018
07:41 AM
- last edited on
Jul 25 2018
10:01 AM
by
TechCommunityAP
I have a VBA macro working - mostly - that copies part of an Excel worksheet and pastes (with formatting) into a new Outlook email, between surrounding text blocks.
Trouble is, the macro is not reliable. We take as a given that Outlook is running. The macro fails if it is not, but that's acceptable for the environment the macro is used in.
The macro works fine if Outlook is running with no windows open other than the inbox. It always fails if another email is open, whether the Inbox or that email is frontmost. In the case where an email is already open, the new email is created with the proper subject and such but the clipboard gets pasted into the email that was already open before the macro was called. [correction] The only scenario that works as intended is when Outlook is running, not minimized, and no document windows open.
How can I make sure the active selection point in Outlook is placed into the macro-created email?
Here's my code. Not shown is the Excel code that has already copied the desired content to the clipboard.
Dim strbody1 As String
Dim strbody2 As String
Dim objMail As Outlook.MailItem
Dim objInsp As Inspector
Dim objDoc As Word.Document
Dim objSel As Word.Selection
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
strbody1 = “Leading text appears before Excel table“
strbody2 = “Following text appears after Excel table“
' Opens email and adds subject and text
Set objMail = Outlook.Application.CreateItem(0)
With objMail
.Display
.Subject = “My Subject”
End With
'Pastes table to email
Set objInsp = objMail.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
With objSel
.InsertAfter vbCr & strbody2
.HomeKey unit:=wdStory
.PasteAndFormat (wdformatorginalformatting)
.EndOf unit:=wdStory, Extend:=wdMove
.HomeKey unit:=wdStory
.InsertAfter strbody1 & vbCr
End With
End If
Set objMail = Nothing
May 24 2018 09:32 AM
Wayne-
In order to avoid issues you can first check to see if Outlook is open, like shown on Ron De Bruin's website here:
https://www.rondebruin.nl/win/s1/outlook/openclose.htm
Sub TestOutlookIsOpen() Dim oOutlook As Object On Error Resume Next Set oOutlook = GetObject(, "Outlook.Application") On Error GoTo 0 If oOutlook Is Nothing Then MsgBox "Outlook is not open, open Outlook and try again" Else 'Call NameOfYourMailMacro End If End Sub
If you incorporate this into the code it may help resolve your issue. If you still have issues, feel free to post back and I can help you incorporate the snippet into your code.
May 24 2018 11:55 AM
I'm familiar with that excellent site, but it does not address the issue I'm having. (Or at least I can't find it.) I don't care if the macro fails when Outlook is not open. The folks using the macro use Outlook all day long.
May 24 2018 01:42 PM
Wayne-
Sorry I think I misunderstood your issue. I haven't fiddled around with Outlook VBA in a while, but maybe try changing this line:
Set objInsp = objMail.GetInspector.CurrentItem
If that doesn't work try these two modifications:
Add this to your Dim Statements:
Dim outApp As Outlook.Application
Then change this code as well:
Set objInsp = outApp.ActiveExplorer.CurrentItem
If neither of these will work. Please let me know and I can do additional testing to try and replicate your issue.
May 25 2018 08:25 AM
Sorry about the delay. I work on a Mac but this code has to be tested on a Windows machine.
Anyway, the .CurrentItem attempt returned a "type Mismatch" error. My tester reports that .CurrentView was on the list of suggestions but .CurrentItem was not.
The second attempt, the Dim statement and the objInspector line returned an error "object variable or with block variable not set"
May 25 2018 10:28 AM
Wayne-
No problem. I'll run some additional tests. However, before I do, I wanted to ask a few questions
I see MS Word VBA references in your code which makes me wonder:
1. If possible would you like to copy data from Excel directly to the email?
2. Are you trying to copy a table from word to the email?
3. Is word being used as some type of intermediary? If so what is the purpose?
The only reason I ask about these items is because there is a way to copy directly from excel and maintain formatting, but if you are trying to copy the table from word then the code will be different of course....
May 25 2018 10:39 AM - edited May 25 2018 03:40 PM
@Matt Mickle wrote:1. If possible would you like to copy data from Excel directly to the email?
Exactly. Trying to paste in formatted Excel cells. Every Outlook example I could find creates an attachment to excerpt the Excel selection, and attaches that to the email in Outlook. I need to put the formatted Excel selection directly into the email. I found a description of the VBA limitation with Outlook that prohibits this, and that's where using the WordEditor code comes in. As noted earlier this does work but only in a limited set of circumstances (no other open Outlook doc).
2. Are you trying to copy a table from word to the email?
Ultimately, no, I have no need for Word except to enable pasting in formatted Excel content.
3. Is word being used as some type of intermediary? If so what is the purpose?
Yes, intermediary ONLY, to enable pasting formatted Excel content for the ultimate destination - an Outlook email.
FWIW, I found some code here...
https://www.datanumen.com/blogs/quickly-close-open-items-except-current-one-outlook/
...that works to close any other open Outlook windows and ultimately puts all the text in the right place. However my tester notes that here customers signature is lost as well as the email formatting. I believe the Excel information retains its format but I can check.
May 25 2018 05:58 PM - edited May 26 2018 07:10 AM
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.
May 26 2018 10:12 AM
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
May 26 2018 02:21 PM
May 31 2018 07:22 AM
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.
Jun 01 2018 10:04 AM - edited Jun 01 2018 10:06 AM
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.
Jun 01 2018 10:52 AM
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..
Jun 01 2018 10:55 AM - edited Jun 01 2018 11:25 AM
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.
Jun 01 2018 12:01 PM - edited Jun 01 2018 12:02 PM
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).
Jun 01 2018 01:07 PM - edited Jun 01 2018 01:27 PM
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
Jun 05 2018 04:22 PM
Jun 05 2018 04:22 PM
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.
Jun 07 2018 12:21 PM - edited Jun 07 2018 12:27 PM
Jun 07 2018 12:21 PM - edited Jun 07 2018 12:27 PM
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
Jun 07 2018 12:42 PM - edited Jun 07 2018 12:43 PM
Wayne-
How Exciting!! Glad you were able to get it working! I'll have to remember that for future reference!
Cheers!