Send Active sheet Used Range with images in Email body

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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I have spent hours looking for an answer to this as well. If it is not possible is there any way to take a screenshot of a range of cells and send that either embedded in the email body or even by attachment?

I can't find either.
 
Upvote 0
If you are going to send the Sheets UsedRange, why not simply Send the Sheet, it's basically the same thing ?


Have a look here for sending sheets AND / OR Selections !!

Mail from Excel with Outlook (VBA)
 
Upvote 0
If you are going to send the Sheets UsedRange, why not simply Send the Sheet, it's basically the same thing ?


Have a look here for sending sheets AND / OR Selections !!

Mail from Excel with Outlook (VBA)

The main reason is the sheet that I am sending is built using a bunch of excel addins that give the #NAME error on all other PC's that open the sheets. The addins link to the accounting software on my computer so installing that on every computer I email the sheets to isn't an option.

Also, don't want to rely on outlook to send, prefer it to go via gmail, but I imagine the code can be easily configured for that.
 
Upvote 0
Ok, good luck then.....I don't have / need / or want gmail !
But have you considered using code to copy the sheet in question and then setting all cells to values only.....then sending the sheet out ?
Hopefully someone else will be able to jump in and assist...(y)
 
Upvote 0
HAHA, OK, don't help with the gmail part. I was just working on the value thing. Here is the code I found online but I am getting an error on the line "for each sh....."

saying sh isnt defined

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

    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("Sheet1", "Sheet3")).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"
        .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
At the start of the code type
Code:
Dim sh as worksheet
 
Upvote 0
At the start of the code type
Code:
Dim sh as worksheet

Great thank-you. I would like to use more than 1 sheet so I have followed the instructions to do so but now I get runtime error 9 subscript out of range. The last line of code posted below is the error, hopefully don't need more than that.

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
    

    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("Sheet1", "Sheet2", "Sheet8")).Copy
 
Upvote 0
the line in question is relative to the original user
Code:
Sourcewb.Sheets(Array("Sheet1", "Sheet2", "Sheet8")).Copy

Change the sheet names inside the array to suit your requirements.
I'm guessing you don't have a "Sheet8" hence the error message
 
Upvote 0
I do have 8 sheets, but they are named not actually called sheet8. When I go into VBA editor though it lists them as Sheet# (mysheetname) So I thought just sheet numbers would work. Do you have paypal or bitcoin or anyway I can donate for your help? This is going to save me a ton of time when complete.
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,543
Latest member
MartinLarkin

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