Send Active sheet Used Range with images in Email body

P

pdileep382

New Member
Joined
Aug 30, 2013
Messages
27
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
clear.png
ublishsource=", _
"align=left x
clear.png
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
 
Sort by date Sort by votes
Upvote 0

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
I'm a bit confused. I would be taking a picture and then just inserting the picture into a workbook and sending that instead?

I think I have the macro working but it has been "working" for 15 minutes now. The 1 tab is massive and with the plugin to my accounting software takes about 10 minutes to update, my guess is that this macro is copying and pasting it then copying pasting values not just copying it and pasting it values directly?

Thoughts? Anyway to change that or is this camera the way to go then?
 
Upvote 0
I would be taking a picture and then just inserting the picture into a workbook and sending that instead?
Click to expand...
Yes..., it was just a thought...it may be quicker and more suited to your needs !
 
Upvote 0
I wish I was better at VBA to have a clue how to input that into the code I have so far and try that instead.

Here is code so far:

Code: 
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy

Sub CDO_Mail_ActiveSheet_Or_Sheets()
'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
    

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

    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", "Data")).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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    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") = "removed@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "removed"
        .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 = "jplaisier@hudsonstaphouse.com"
        .CC = ""
        .BCC = ""
        .From = """Ron"" <ron@something.nl>"
        .Subject = "This is a test"
        .TextBody = "Hi there"
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


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

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Upvote 0
I don't have Excel at the moment, but use the camera tool to take the picture.
Save the picture to say, "C:\Temp" as "Picture1"
Then change the line in the code
Code: 
.AddAttachment "C:\Temp\Picture1.jpg"
You may have to change the picture extension from jpg to whatever the format is
 
Upvote 0
Hmm,

Well I pretty much have this doing everything I need as of now. Not sure what benefits are left in moving this to a picture?

Here is the code as of now since I made a few changes, just 2 minor things left to do, and 1 Major (pipe dream)

Code: 
Option Explicit

'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy

Sub CDO_Mail_ActiveSheet_Or_Sheets()
'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
      

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    'Unprotect worksheets to be copied to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect
    Next ws


    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")).Copy
    
    'Protection back on for worksheets copied over to destination workbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect
    Next ws

    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
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    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 = "secret"
        .CC = ""
        .BCC = ""
        .From = """Ron"" <ron@something.nl>"
        .Subject = "This is a test"
        .TextBody = "Hi there"
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With


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

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

Here is what I would like changed and can't figure out.

1. The attachment right now comes out like this "My file.xlsm - mmm dd yyyy.xlsm" I would like to remove the first .xlsm as that isn't the extension but just in the file name?

2. The file that I send out does not need to be macro enabled at all and will likely just cause some security warnings on recipients PC's so just save it as a regular .xlsx file?

3. THE DREAM - As mentioned earlier in this thread the "data" tab in the source workbook takes forever to copy and paste over in this macro likely due to the plugin that has each cell pull from my accounting software, so I would like to either have this code copy and paste values from the start (instead of copying pasting then copying and pasting valued over top) OR only copying 7 lines from the data tab. Cell A1 on the "dashboard" tab has a date, I would like to find that date in column A1 on the data tab and only copy that row and the 6 rows before it up to column AB.

Thanks for all the help!!


Edit: I have modified the code to only copy the "dashboard" tab for now but that would need to be changed as well if an answer for 3 is found.
</ron@something.nl>
 
Upvote 0
Still don't have EXcel, so.... UNTESTED
Not quite sure on point No 3...
Code: 
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
    Dim FileExtStr As String, FileFormatNum As Long
    Dim Sourcewb As Workbook, Destwb As Workbook, TempFilePath As String
    Dim TempFileName As String, iMsg As Object, iConf As Object
    Dim Flds As Variant, sh As Worksheet, ws As Worksheet
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect
    Next ws
    Set Sourcewb = ActiveWorkbook
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect
    Next ws
    Set Destwb = ActiveWorkbook
    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
                .Value = .Value
            End With
        Next sh
        Destwb.Worksheets(1).Select
    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 = "secret"
        .CC = ""
        .BCC = ""
        .From = """Ron"" "
        .Subject = "This is a test"
        .TextBody = "Hi there"
        .AddAttachment TempFilePath & TempFileName
        .Send
    End With
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Last edited:
Upvote 0
Doesn't work. If I run the code I pasted I get the email, and when I run your code I get "the cell or chart that you are trying to change is protected and therefore read-only"

The line it comes up on is:

.Value = .Value

If I run original code right after still works, so not too sure what is causing this.
 
Upvote 0
That's because the sheets are protected
Change this code
Code: 
For Each sh In Destwb.Worksheets
            sh.Select
            With sh.UsedRange
                .Value = .Value
            End With
        Next sh


TO

For Each sh In Destwb.Worksheets
            sh.Select
            sh.unprotect
            With sh.UsedRange
                .Value = .Value
            End With
        Next sh
 
Upvote 0
Shoot sorry, should have reported it's figured out. I am SO close now and have added A LOT over the last 7 hours. I figured out how to solve #3 on the list above by having the "data" tab pasted in the source workbook as values, then copy that values tab over to the email to send, then delete the newly created values tab!! Pretty proud about this!

2 things left!!

Code: 
Option Explicit  '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     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     Application.DisplayAlerts = False          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 = """Ron"" "         .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      With Application         .ScreenUpdating = True         .EnableEvents = True     End With          Application.DisplayAlerts = True End Sub

1.) The spreadsheet that gets attached in the emails is caleed Filename.xlsm - Date.xlsx the first .xlsm does nothing and I would prefer to have that removed from the file name, what do I need to change?
2.) How do I change the subject to use the text in a cell from the workbook instead of a constant typed in quotations?
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
VBA - Email specific range and attach Sheet1
Replies
4
Views
496
Clermont
C
G
  • Question
Email from Excel query
Replies
0
Views
171
gmazza76
G
J
  • Question
Outlook Hypperlink of fila in email body will not open
Replies
1
Views
436
josros60
J
A
  • Question
Ron de Bruin VBA
Replies
2
Views
991
Alexfoots
A
J
  • Question
Kill Temp File
Replies
1
Views
337
ExcelToDAX
E

Forum statistics

Threads
1,215,069
Messages
6,122,952
Members
449,095
Latest member
nmaske

Share this page

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