VBA to send a spreadsheet range to multiple email recipients

srdavisgb

Board Regular
Joined
Nov 5, 2011
Messages
51
Thanks in advance for your help! :cool:

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.
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
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:

Code:
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
 
Upvote 0
A little change in this part:
Remove red lines and add HTMLBody

Code:
    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
 
Upvote 0
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
 
Upvote 0
Try:

Code:
[/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]
 
Upvote 0
You're welcome.

Note: Remember, "Name" is a word reserved for VBA
 
Last edited:
Upvote 0

Forum statistics

Threads
1,214,360
Messages
6,119,074
Members
448,866
Latest member
CKW USMC

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top