Sending Outlook mail using Excel VBA

Deleted
Not applicable

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

 

18 Replies

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.

 

 

 

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.

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.

 

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"

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....

 

 


@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.

 

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
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!

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.

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-

 

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..

 

 

MultipleAppsOpen.png

 

 

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-

 

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).

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

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.

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

Wayne-

 

How Exciting!!  Glad you were able to get it working!  I'll have to remember that for future reference!  

 

Cheers!