VBA - Copying Range to an E-Mail Body

[cwhaley1]

Hi all, I have a spreadsheet which pulls through the data contained on 5 SharePoint spreadsheets into a separate Excel spreadsheet. This uses Power Query. This is working well and odes what I need.

I have written a crude VBA code which refreshes all the data connections, takes a copy of the tables from each tab and pastes them onto a tab within the sheet. I would then like this range of data to be copied into an e-mail body.

I don't understand why the below code won't fully work. The part I'm struggling with is

 .Body = Range("B2:K44")

but I have pasted the full code below for clarity. Excel tells me "the object does not support this method". All the code above works absolutely fine.

Sub Filter_Controller()

 Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, email As Range
    Set OutApp = CreateObject("Outlook.Application")
    Dim ws As Worksheet
    Dim r As Range
    
    
    Worksheets("Project_Set_Up_Checks").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Project_Set_Up_Checks").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
          
    Worksheets("Opportunity_Contact_Checks").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Opportunity_Contact_Checks").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
  
    Worksheets("Opportunity_Contacts").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Opportunity_Contacts").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
    
    Worksheets("Live_Projects_Last_Booking").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
     ActiveSheet.ListObjects("Live_Projects_Last_Booking").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
       
    Worksheets("Potential_Closures_No_Comment").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
     ActiveSheet.ListObjects("Potential_Closures_No_Comment").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
       
       
       Sheets("Project_Set_Up_Checks").Select
        Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B22").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Opportunity_Contact_Checks").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B26").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Opportunity_Contacts").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B30").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Live_Projects_Last_Booking").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B34").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Potential_Closures_No_Comment").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B38").Select
    ActiveSheet.Pictures.Paste.Select
    Range("B4:AD41").Select
            
               
    
 Application.ScreenUpdating = False
   
    
    Worksheets("Main").Activate
    'Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Clear
                
    For Each email In Range("J4", Range("J" & Rows.Count).End(xlUp))
        Set OutMail = OutApp.CreateItem(0)
            With OutMail
            .SentOnBehalfOfName = "e-mail goes here" 'this is the "from" field
            .To = email
            .Subject = "Data Cleansing Reminder - " & Date
            .Body = Range("B2:K44") 'this references the cell where the body of the e-mail is written
            .Save
            .Display
            '.send '<<<<<to send without the option of reviewing first, remove the "'"
        End With
    Next email
    Application.ScreenUpdating = True
  
            
Worksheets("E-Mail Body").Select

ActiveSheet.Pictures.Delete

End Sub

 

[Logit]

Here is the "guts" of the email macro. You'll need to add to it as you see fit to accomplish the remainder of your
project goal :

Sub SendEmailWithRange()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim MailBody As String
    Dim i As Integer, j As Integer
    Dim rng As Range
    Dim cell As Range
    
    ' Set the range to be copied
    Set rng = ThisWorkbook.Sheets("Main").Range("B2:K44")
    
    ' Construct the mail body
    MailBody = ""
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            MailBody = MailBody & rng.Cells(i, j).Value & vbTab
        Next j
        MailBody = MailBody & vbNewLine
    Next i
    
    ' Create an instance of Outlook application
    Set OutlookApp = CreateObject("Outlook.Application")
    
    ' Create a new mail item
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    ' Set mail properties
    With OutlookMail
        .SentOnBehalfOfName = "e-mail goes here" 'this is the "from" field
        .To = "recipient@example.com"
        .Subject = "Range B2:K44 from Sheet Main"
        .Body = MailBody
        '.Send
        .Display
    End With
    
    ' Clean up
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

 

[cwhaley1]

Many thanks for this Logit. I'll incorporate it into my code and report back on here if it's my solution.

 

[cwhaley1]

I've incorporated your code and made a few changes and can confirm it does what I want which is great.

Thanks for your help - it's taught me a better way of writing code to create an e-mail.

 

[Logit]

Glad to help. Cheers.

 

[cwhaley1]

I have a further requirement from this which I have not yet been able to meet. I would like the body of the e-mail to be the contents of the clipboard (a single image) as copying a range containing pictures does not include them.

I think I need to amend the below line to reference the clipboard rather than a range within the workbook. Is there an easy way of doing this?

    Set r = ThisWorkbook.Sheets("E-Mail Body").Range("B4:W30")

 

[Logit]

Disregard utilizing the clipboard. The following macro will transform the range specified in the code into an image and paste that image
into the body of the email. It will combine data in cells as well as any image that might be located within the specified range.

Option Explicit


Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    
    Dim plage As Object
    
    ThisWorkbook.Activate
    Worksheets(Namesheet).Activate
    
    Set plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    plage.CopyPicture
    
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(plage.Left, plage.Top, plage.Width, plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    
    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
    Set plage = Nothing

End Sub

Sub sendMail()
        
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Dim TempFilePath As String 'location of temp image
    Dim imgRNG As String 'area for image
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As Variant
    
    imgRNG = "A1:N37" 'change this for range

    'Create a new Microsoft Outlook session
    Set OutApp = CreateObject("outlook.application")
            
    'create a new message
    Set OutMail = OutApp.CreateItem(0)
            
    With OutMail
    
        .Subject = "Insert Subject here"
        
        'following bit is to setup the image
        Call createJpg("Sheet1", imgRNG, "MailAttach") 'Worksheet name <---------------------  <---------------------
        TempFilePath = Environ$("temp") & "\"
        .Attachments.Add TempFilePath & "MailAttach.jpg", 0, 0
            
        'Then we add an html <img src=''> link to this image
        '<br> = line break
        '
        strbody = "<span LANG=EN>" & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
        & "Hello,<br><br>Insert message here, use for next line" & _
        "<br><B>Image:</B><br><br><img src='cid:MailAttach.jpg'<br>"
        
        .Display 'display email to grab signature
        .htmlbody = strbody & "<br>" & .htmlbody ' pass body of text then line break then insert signature
        
        .To = "contact1@email.com; contact2@email.com"
        .Cc = "contact3@email.com"
        '.Send 'if you want to autosend enable this
        
    End With
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub