VBA Code to Email Active Worksheet but also Paste Cell Range into Body of Email **Please help!

[pxstan]

Hello,

I'm trying to create a macro that will email the active worksheet as an attachment, but then also copy and paste the cell range into the body of the email, basically pasting the worksheet range as a picture in the body of the email along with sending it as an attachment.

I have the macro already working great for emailing the attachment, but I can't figure out how to modify it to add a cell range into the body of the email. Any help would be greatly appreciated.

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    Set Sourcewb = ActiveWorkbook


    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook


    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With


    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


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


    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = "Test@ABCCompany.com"
            .CC = ""
            .BCC = ""
            .Subject = "Daily Patient Flow Report"
            .Body = "Please find the attached Daily Patient Flow Report for " & Now
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing
    Set OutApp = Nothing


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

 

[Logit]

.
The following will create an email, save the named sheet as an .xlsx file and attach it to the email ... as well as paste the sheet contents into the body of the email.
Hopefully you can adapt some of the code to your purposes:

Option Explicit


Sub SveShts()


Dim xPath As String
Dim xWs  As String


'Establish location of this workbook
xPath = Application.ActiveWorkbook.Path


Application.ScreenUpdating = False
Application.DisplayAlerts = False


'Copy specified sheet to be attached to email. Edit sheet name as required. Sheet is saved as a XLSX workbook
'in same location as this workbook
With Sheets("Sheet1")
    Sheets("Sheet1").Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & ActiveSheet.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'Call the CopyRows macro (below)
CopyRows
End Sub


'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Pivot1")  '<<-- edit sheet name as required
    ws1.Range("A1:N79").Copy
    Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String


Dim xPath As String
Dim xWs  As String


xPath = Application.ActiveWorkbook.Path


Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Pivot1").Range("A1:N79")  '<<----- edit range as required


If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If


'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


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


With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    .Attachments.Add "C:\Users\My\Desktop\Sheet1.xlsx"  '<<--- edit path as required
    
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With


On Error GoTo 0


'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With


'Delete the temporary .xlsx file created for attachment
Kill "C:\Users\My\Desktop\*.xlsx"


Set OutMail = Nothing
Set OutApp = Nothing


End Sub


''<<<>>> There is no need to edit anything in this Function.


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

 

[pxstan]

I've spent the past two days trying to figure this out using the above new code, but I can't seem to get it to work. I'm sure it's user error on my part as I'm very new to this stuff. Are you able to tell me which part of the code needs to be updated/adapted for it to work for me? Am I only changing "Sheet1" to my actual sheet name and changing "Pivot1" to my actual sheet name along with changing the Range "A1:N79" to my acutal cell range? For the attachments add file path will this need to be constant?...If multiple people are using this will it need to be saved in a specific location so that the file path doesn't change?...Sorry for all these questions, but I'm trying to do this with very little experience. Thanks again for any assistance.

 

[Logit]

.
I believe this will solve your question ?

Create a folder on the desktop named Send Email and place this workbook inside that folder.

Use these macros to replace the existing :

Option Explicit




Sub SveShts()
Dim MyFolder As String
Dim fname As String, ext As String


   MyFolder = Application.ActiveWorkbook.Path
   fname = "Pivot1"
   ext = ".xlsx"
   
Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Sheets("Pivot1").Copy
    ActiveWorkbook.SaveAs Filename:=MyFolder & "\" & fname & ext, _
         CreateBackup:=False
    ActiveWorkbook.Close True
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True


CopyRows




End Sub




'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Pivot1")  [B]'<<-- edit sheet name as required[/B]
    ws1.Range("A1:N79").Copy  [B]'<<----- edit range as required[/B]
    Mail_Selection_Range_Outlook_Body
End Sub




Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String




Dim xPath As String
Dim xWs  As String




xPath = Application.ActiveWorkbook.Path




Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Pivot1").Range("A1:N79")  [B]'<<----- edit sheet name & edit range as required[/B]




If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If




'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With




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




With OutMail
    .to = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"




    .HTMLBody = "Text above Excel cells" & "<br></br>" & _
                RangetoHTML(rng) & "<br></br>" & "Text below Excel cells."




    .Attachments.Add "C:\Users\My\Desktop\Send Email\Pivot1.xlsx"  [B]'<<--- edit path as required that leads to your desktop and the SEND EMAIL folder. edit sheet name if necessary[/B]
    
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With




On Error GoTo 0




'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With




'Delete the temporary .xlsx file created for attachment
Kill "C:\Users\My\Desktop\Send Email\*.xlsx"  [B]'<<--- edit path as required that leads to your desktop and the SEND EMAIL folder[/B]




Set OutMail = Nothing
Set OutApp = Nothing




End Sub




''<<<>>> There is no need to edit anything in this Function.




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