Outlook Issue within macro

[mikeellinas]

I have a macro that copies specific cells of a worksheet, opens outlook, and pastes the selection into the outlook email. It works great with one exception - there cannot be any other outlook windows opened. For example, if I started a new email and then minimized it, when I run the macro, the image is pasted into the email window I had minimized instead of opening a new one.

Can someone advise if there is a workaround for this?

Here is the code I am using:

Sub Email()

Dim finalRow As Long
Dim r As Range
Dim wordDoc As Document
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String

'Set procedure variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set wordDoc = OutMail.GetInspector.WordEditor

'Last Row Query
finalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row

'Delete unused rows

For x = finalRow To 1 Step -1
    If Cells(x, 1) = "-Change Type-" Then
        Rows(x).EntireRow.Delete
    End If
Next x

'Reset the last row indicator after the unnecessary rows are deleted

finalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row

'Copy range of interest

Set r = Range("A1:E" & finalRow)
r.Copy

If Sheets("My Form").Rows(7).EntireRow.Hidden = False Then
    strSubject = "My Subject: " & _
                 Range("A3").Value & _
                 " My Data " & _
                 Range("A4").Value & _
                 " Date Data: " & _
                 Range("C8").Value
Else
    strSubject = "My Subject: " & _
                 Range("A3").Value & _
                 " My Data " & _
                 Range("A4").Value & _
                 " Date Data: " & _
                 Range("C9").Value
End If
 
 

'Open a new mail item and define message content
With OutMail
    .CC = "[EMAIL="mike@aol.com"]mike@aol.com[/EMAIL]"
    .Subject = strSubject
    .HTMLBody = " " & .HTMLBody
    r.CopyPicture Format:=xlPicture
    .Display
    wordDoc.Application.ActiveDocument.Characters(1).Select
    
    With wordDoc.Application.Selection
        .End = .Start
        .Paste
    End With
    
End With
'housekeeping to reinitialize variables
Set OutMail = Nothing
Set OutApp = Nothing

'ThisWorkbook.Close SaveChanges:=False
End Sub

 

[mole999]

maybe setting Set OutMail = Nothing before you start to assemble would close the issue

 

[mikeellinas]

maybe setting Set OutMail = Nothing before you start to assemble would close the issue

thank you, mole999. I am a total newb here. Can you tell me where to insert that? I am not sure what/where "before you start to assemble" is located in the code I posted.

 

[mole999]

I'm Guessing (as I'm not sure)

'Open a new mail item and define message content
[COLOR=#ff0000]Set OutMail = Nothing[/COLOR]
With OutMail
    .CC = "[EMAIL="mike@aol.com"]mike@aol.com[/EMAIL]"
    .Subject = strSubject
    .HTMLBody = " " & .HTMLBody
    r.CopyPicture Format:=xlPicture

 

[Norie]

When you run the code you will have a reference to the correct Word document for the email you are composing in the variable wordDoc even if there are multiple emails open.

However when it comes to trying to paste into the correct email you have this which will paste into the active document of the Word application that's being used as an editor in Outlook.

 wordDoc.Application.ActiveDocument.Characters(1).Select
    
    With wordDoc.Application.Selection
        .End = .Start
        .Paste
    End With

You need to change this code so it pastes into the document wordDoc refers to, not the active document, try this.

Option Explicit

Sub Email()

Dim finalRow As Long
Dim r As Range
Dim wordDoc As Object
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String
Dim x As Long

    'Set procedure variables
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set wordDoc = OutMail.getinspector.WordEditor
  
    'Last Row Query
    finalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row

    'Delete unused rows

    For x = finalRow To 1 Step -1
        If Cells(x, 1) = "-Change Type-" Then
            Rows(x).EntireRow.Delete
        End If
    Next x

    'Reset the last row indicator after the unnecessary rows are deleted

    finalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row

    'Copy range of interest

    Set r = Range("A1:E" & finalRow)
    r.Copy

    If Sheets("My Form").Rows(7).EntireRow.Hidden = False Then
        strSubject = "My Subject: " & _
                     Range("A3").Value & _
                     " My Data " & _
                     Range("A4").Value & _
                     " Date Data: " & _
                     Range("C8").Value
    Else
        strSubject = "My Subject: " & _
                     Range("A3").Value & _
                     " My Data " & _
                     Range("A4").Value & _
                     " Date Data: " & _
                     Range("C9").Value
    End If

    'Open a new mail item and define message content
    With OutMail
        .CC = "mike@aol.com"
        .Subject = strSubject
        .HTMLBody = " " & .HTMLBody
        r.CopyPicture Format:=xlPicture
        .Display

        With wordDoc.Paragraphs(1).Range
            .End = .Start
            .Paste
        End With

    End With
    'housekeeping to reinitialize variables
    Set OutMail = Nothing
    Set OutApp = Nothing

    'ThisWorkbook.Close SaveChanges:=False
End Sub

 

[mikeellinas]

Thanks, Norie! This worked perfectly.