VBA to send a spreadsheet range to multiple email recipients

[srdavisgb]

Thanks in advance for your help!

I am trying to send a spreadsheet range in the body of an email to multiple recipients. Below is my code which is set to display the email for testing (I will change to msg.send later).

The code stops at

"msg.body = sh.Range("D5:O" & last_row).Value"

with an error message of "The object does not support this method."

Any thoughts on what I have done wrong?



Sub Send_Mail()
'
' Send_Mail Macro
'
Dim OA As Object

Set OA = CreateObject("outlook.application")

Dim sh As Worksheet
Dim last_row As Integer

Name = Cells(7, 51)
last_row = Cells(15, 20) + 6

Set sh = ThisWorkbook.Sheets(Name)

Dim i As Integer
Dim r As Long

For i = 7 To last_row

With Selection.Parent.MailEnvelope.Item

Set msg = OA.createitem(0)
msg.To = sh.Range("AX" & i).Value
msg.Subject = sh.Range("Az7").Value
msg.body = sh.Range("D5:O" & last_row).Value
msg.display

End With

Next i

sh.Range("aw" & i).Value = "Sent"

MsgBox "All the mails have been sent successfully"

End Sub


Thanks again for your assistance.

 

[rconverse]

Maybe try

msg.body = sh.Range("D5:O" & last_row)

 

[DanteAmor]

You cann't send a range of cells, only a string.


One option is to send the range of cells as HTML, use the following:

Sub Send_Mail()
    '
    ' Send_Mail Macro
    '
    Dim OA As Object
    
    Set OA = CreateObject("outlook.application")
    
    Dim sh As Worksheet
    Dim last_row As Integer
[COLOR=#0000ff]    Dim rng As Range[/COLOR]
    
    Name = Cells(7, 51)
    last_row = Cells(15, 20) + 6
    
    Set sh = ThisWorkbook.Sheets(Name)
[COLOR=#0000ff]    Set rng = sh.Range("D5:O" & last_row)[/COLOR]
    
    Dim i As Integer
    Dim r As Long
    
    For i = 7 To last_row
        With Selection.Parent.MailEnvelope.Item
            Set msg = OA.createitem(0)
            msg.To = sh.Range("AX" & i).Value
            msg.Subject = sh.Range("Az7").Value
            msg.body = [COLOR=#0000ff]RangetoHTML(rng)[/COLOR]
            msg.display
        End With
    Next i
    
    sh.Range("aw" & i).Value = "Sent"
    
    MsgBox "All the mails have been sent successfully"


End Sub
'
[COLOR=#0000ff]Function RangetoHTML(rng As Range)[/COLOR]
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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

 

[DanteAmor]

A little change in this part:
Remove red lines and add HTMLBody

    For i = 7 To last_row
[COLOR=#ff0000]        'With Selection.Parent.MailEnvelope.Item[/COLOR]
            Set msg = OA.createitem(0)
            msg.To = sh.Range("AX" & i).Value
            msg.Subject = sh.Range("Az7").Value
            msg.[COLOR=#0000ff]HTMLBody [/COLOR]= RangetoHTML(rng)
            msg.display
[COLOR=#ff0000]        'End With[/COLOR]
    Next i

 

[srdavisgb]

Dante,

Thanks for you help. Without the Microsoft Outlook 16.0 Object Library selected, the macro runs one time and sends an email with what looks like html code for the body. On the second loop, the code stops at "With Selection.Parent.MailEnvelope.Item".

When I select the Microsoft 16.0 Object Library as a reference, I get an error "Compile error: Can't assign to read-only property." at the worksheet "Name." And, no emails are sent. The worksheet "Name" is a date with the following formula "=TEXT($B$3,"ddmmmyyyy")", I thought it might be tripping up the code, so I pasted it as a value. This didn't resolve the error.

Any thoughts?

Steve

' Send_Mail Macro
'
Dim OA As Object

Set OA = CreateObject("outlook.application")

Dim sh As Worksheet
Dim last_row As Integer
Dim rng As Range

Name = Cells(7, 51)
last_row = Cells(15, 20) + 6

 

[DanteAmor]

Try:

[/COLOR]Sub Send_Mail()
    '
    ' Send_Mail Macro
    '
    Dim OA As Object
    
    Set OA = CreateObject("outlook.application")
    
    Dim sh As Worksheet
    Dim last_row As Integer
    Dim rng As Range

[COLOR=#0000ff]Dim wName as string[/COLOR]
[COLOR=#0000ff]    [/COLOR]
[COLOR=#0000ff]    wName = Cells(7, 51).text
[/COLOR]

    last_row = Cells(15, 20) + 6
    
    Set sh = ThisWorkbook.Sheets([COLOR=#0000ff]wName[/COLOR])
    Set rng = sh.Range("D5:O" & last_row)
    
    Dim i As Integer
    Dim r As Long
    
    For i = 7 To last_row
        
            Set msg = OA.createitem(0)
            msg.To = sh.Range("AX" & i).Value
            msg.Subject = sh.Range("Az7").Value
            msg.body = RangetoHTML(rng)
            msg.display
        
    Next i
    
    sh.Range("aw" & i).Value = "Sent"
    
    MsgBox "All the mails have been sent successfully"




End Sub
'
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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
[COLOR=#333333]

 

[srdavisgb]

Thanks - that did it!

 

[DanteAmor]

You're welcome.

Note: Remember, "Name" is a word reserved for VBA