Code to copy multiple worksheets into the body of an email

[lilah]

Hi everyone,

I am using a code that copies multiple worksheets into the body of an email. The workbook could contain anywhere from 1-10 worksheets at any time. The code I am using works great until the number of worksheets in the workbook is less than the max. For example, the code allows for 10 worksheets -- if there are exactly 10 worksheets they are all copied in to the email. As soon as there are only 9 however, the email is generated blank. I am trying to get the email to copy the worksheets present regardless of the number but I'm stumped.
Any ideas would be greatly appreciated!

Here is the code i'm currently butchering:

Sub Mail_Sheet_Outlook_Body()


Dim rng As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim rng7 As Range
Dim rng8 As Range
Dim rng9 As Range
Dim rng10 As Range


Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Set rng = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Set rng5 = Nothing
Set rng6 = Nothing
Set rng7 = Nothing
Set rng8 = Nothing
Set rng9 = Nothing
Set rng10 = Nothing




Set rng = Sheet1.UsedRange
On Error Resume Next
Set rng2 = Sheet2.UsedRange
On Error Resume Next
Set rng3 = Sheet3.UsedRange
On Error Resume Next
Set rng4 = Sheet4.UsedRange
On Error Resume Next
Set rng5 = Sheet5.UsedRange
On Error Resume Next
Set rng6 = Sheet6.UsedRange
On Error Resume Next
Set rng7 = Sheet7.UsedRange
On Error Resume Next
Set rng8 = Sheet8.UsedRange
On Error Resume Next
Set rng9 = Sheet9.UsedRange
On Error Resume Next
Set rng10 = Sheet10.UsedRange
On Error Resume Next


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = "Label Change Group"
.CC = ""
.BCC = ""
.Subject = "Packaging Update"
.HTMLBody = RangetoHTML(rng) & "<br>" & RangetoHTML(rng2) & "<br>" & RangetoHTML(rng3) & "<br>" & RangetoHTML(rng4) & "<br>" & RangetoHTML(rng5) & "<br>" & RangetoHTML(rng6) & "<br>" & RangetoHTML(rng7) & "<br>" & RangetoHTML(rng8) & "<br>" & RangetoHTML(rng9) & "<br>" & RangetoHTML(rng10)
.display 'or use .Send
End With
On Error GoTo 0


With Application
.EnableEvents = True
.ScreenUpdating = True
End With


Set OutMail = Nothing
Set OutApp = Nothing
End Sub






Function RangetoHTML(rng As Range)


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

 

[Norie]

This code should work no matter the no of worksheets are in the workbook.

It assumes the worksheets you want in the email are in the same workbook as the code is in and that
you want the data from all the worksheets in the workbook.

That can be changed if required.

Sub Mail_Sheet_Outlook_Body()
Dim ws As Worksheet
Dim rng As Range
Dim strHTMLBody As String
Dim OutApp As Object
Dim OutMail As Object
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    For Each ws In ThisWorkbook.Worksheets
        Set rng = ws.UsedRange
        strHTMLBody = strhrmlbody & RangetoHTML(rng)
    Next ws
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "Label Change Group"
        .CC = ""
        .BCC = ""
        .Subject = "Packaging Update"
        .HTMLBody = strHTMLBody
        .Display    'or use .Send
    End With
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

 

[lilah]

Thanks for your quick reply! I tried the code you provided, but I am still only getting one worksheet copied into the email (unless they are being copied on top of one another?). Any other suggestions?

 

[Norie]

There's a typo.

strHTMLBody = strHTMLBody & RangetoHTML(rng)

 

[lilah]

You're a lifesaver!! Thank you so much for your help!