Send Active sheet Used Range with images in Email body

[pdileep382]

Hi ,

After searching in google i got the below code. But the below code is with the sending Activesheet used range without images.

I want to send with the images in used range. What changes i need to do with the below code.

Sub Mail_Sheet_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set rng = Nothing
Set rng = ActiveSheet.UsedRange
' You can also use a sheet name here.
'Set rng = Sheets("YourSheet").UsedRange

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

On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
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)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x

ublishsource=", _
"align=left x

ublishsource=")

' Close TempWB.
TempWB.Close savechanges:=False

' Delete the htm file.
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function


Thanks and Regards
Dileep

 

[superskid]

Code posted terribly above:

Here it is again:

'This procedure will send the dashboard tab and a values pasted tab of the data tab
'to the emails listed on the email tab, the spreadsheet will be stripped of macros
'and sent as a *.xlsx file

Sub PasteValueMail()
'Working in 97-2007
    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 iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    'Unprotect worksheets to be copied to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect
    Next ws
    
    'Take a values only copy of "data" tab
    ThisWorkbook.Unprotect "secret"
        With ActiveWorkbook
        Set ws1 = .Worksheets("Data")
        Set ws2 = .Worksheets.Add(After:=ws1)
    End With
    
    ws1.Range("A1:AK369").Copy
    ws2.Name = "DataValues"
    
    With ws2.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    'ActiveSheet.Copy

    'Or if you want to copy more then one sheet use:
    Sourcewb.Sheets(Array("Dashboard", "DataValues")).Copy
    
    ThisWorkbook.Sheets("DataValues").Delete
    ThisWorkbook.Protect Password:="secret", Structure:=True, Windows:=False
    
    'Protection back on for worksheets copied over to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect
    Next ws

    Set Destwb = ActiveWorkbook

    'Change destination workbook to .xlsx,
    
    Application.DisplayAlerts = False
    
    With Destwb
            FileExtStr = ".xlsx": FileFormatNum = 51
    End With

    '    'Change all cells in Destwb to values if you want
        For Each sh In Destwb.Worksheets
            sh.Select
            With sh.UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        Next sh
        Destwb.Worksheets(1).Select


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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close savechanges:=False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "secret@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "secret"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
        End With
                     
        
    With iMsg
        Set .Configuration = iConf
        .To = Sheets("Email").Range("B2").Value & ";" & Sheets("Email").Range("B3").Value & ";" & Sheets("Email").Range("B4").Value & Sheets("Email").Range("B5").Value & ";" & Sheets("Email").Range("B6").Value & ";" & Sheets("Email").Range("B7").Value & Sheets("Email").Range("B8").Value & ";" & Sheets("Email").Range("B9").Value
        .CC = ""
        .BCC = ""
        .From = """secret"" <secret@gmail.com>"
        .Subject = "Dashboard"
        .TextBody = "Attached is the most recent dashboard"
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    
    ThisWorkbook.Sheets("Dashboard").Select

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
End Sub</secret@gmail.com>

 

[Michael M]

Ok, filename is fixed
To use a range for the Subject line, simply refer to that range, just like you did in the To. line
Also, removed some redundat lines for PasteValues....you don't have to select each sheet to work with it...it slows down the code
See the lines highlighted in red are changed

Sub PasteValueMail()
'Working in 97-2007
    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 iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    'Unprotect worksheets to be copied to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect
    Next ws
    
    'Take a values only copy of "data" tab
    ThisWorkbook.Unprotect "secret"
        With ActiveWorkbook
        Set ws1 = .Worksheets("Data")
        Set ws2 = .Worksheets.Add(After:=ws1)
    End With
    
    ws1.Range("A1:AK369").Copy
    ws2.Name = "DataValues"
    
    With ws2.Range("A1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    
    Application.CutCopyMode = False
    

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy

    'Or if you want to copy more then one sheet use:
    Sourcewb.Sheets(Array("Dashboard", "DataValues")).Copy
    
    ThisWorkbook.Sheets("DataValues").Delete
    ThisWorkbook.Protect Password:="secret", Structure:=True, Windows:=False
    
    'Protection back on for worksheets copied over to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect
    Next ws

    Set Destwb = ActiveWorkbook

    'Change destination workbook to .xlsx,
    
    Application.DisplayAlerts = False
    
    With Destwb
            FileExtStr = ".xlsx": FileFormatNum = 51
    End With

    '    'Change all cells in Destwb to values if you want
        For Each sh In Destwb.Worksheets
           With sh.UsedRange
                .Cells.Value = .Cells.Value
            End With
        Next sh
        Destwb.Worksheets(1).Select ' WHY DO YOU NEED TO SELECT THIS SHEET, IF YOU DON'T DELETE THIS LINE !!!


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Format(Now, "mmm dd, yyyy")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close savechanges:=False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "secret@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "secret"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
        End With
                     
        
    With iMsg
        Set .Configuration = iConf
        .To = Sheets("Email").Range("B2").Value & ";" & Sheets("Email").Range("B3").Value & ";" & Sheets("Email").Range("B4").Value & Sheets("Email").Range("B5").Value & ";" & Sheets("Email").Range("B6").Value & ";" & Sheets("Email").Range("B7").Value & Sheets("Email").Range("B8").Value & ";" & Sheets("Email").Range("B9").Value
        .CC = ""
        .BCC = ""
        .From = """secret"" "
        .Subject = "Dashboard" 'change this to a range reference, ie, Range("B2").Value
        .TextBody = "Attached is the most recent dashboard"
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    
    ThisWorkbook.Sheets("Dashboard").Select

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