Copy range, paste in outlook mail and send e-mail

SAS83 · Jun 26th 2015

Hi,

I am trying to copy a range from a worksheet and trying to send by mail.

Please note I do not want to attached file, I just want to copy range from file and paste in email body.

For example I need to copy range A1:B10 from excel file paste it in new email and send it.

Can anyone please help me in this.

Gulam · Jun 27th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi, Try this.

HTML

Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Nothing
    On Error Resume Next
     'Only the visible cells in the selection
    
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
     'You can also use a range if you want


    Set rng = Sheets("Sheet1").Range("C1:H25").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
        vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    strHtml = "<html>" & "<body>" & "Hi All," & "<br>" & "</br>" & "</body>" & "</html>"
         
    With OutMail
        .To = ""
        .CC = ""
        .Subject = "Test Mail""
        .HTMLBody = strHtml & RangetoHTML(rng)
        
         '.Send   'or use .Display
        .Display
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
       ActiveWorkbook.CheckCompatibility = False
  ActiveWorkbook.Save
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 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

Display More

SAS83 · Jun 29th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi Gulam,

Thanks a lot for the help. Sorry for late reply.

I am checking this and will share the results shortly.

Have a nice day ahead.

SAS83 · Jun 29th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi Gulam,

It's working perfect. Thanks a lot for the help !

Regards,

SAS.

SAS83 · Aug 19th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi,

I am trying to understand below mentioned code with each line.

Can anyone please advise me what is ".DrawingObjects.Visible = True and .DrawingObjects.Delete" relates to.

Code

Sub SendEmail()
    Dim Rng As Range 'This is range for E-mail body
    Dim OutApp As Object 'This will start MS Outlook
    Dim OutMail As Object 'This will create new E-mail
    
    Set Rng = Nothing
    Set Rng = ThisWorkbook.Worksheets("sheet1").Range("g6:i17") 'E-mail body
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    'This code will start MS Outlook if it is closed
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    'CreateItem(0) will create new E-mail
    'CreateItem(1) will create new Appointment
    'CreateItem(2) will create new Contact
    'CreateItem(3) will create new Task
    'CreateItem(4) will create Journal Entry
    'CreateItem(5) will create Note (tiny yellow square)
    'CreateItem(6) will create "Post in this Folder" do not know what is this
    'CreateItem(7) will create new Contack Group
    
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
        With OutMail 'This means with created E-mail object
            .SentOnBehalfOfName = ThisWorkbook.Worksheets("sheet1").Range("c1") 'From field
            .To = ThisWorkbook.Worksheets("sheet1").Range("c2")
            .CC = ThisWorkbook.Worksheets("sheet1").Range("c3")
            .Subject = ThisWorkbook.Worksheets("sheet1").Range("c4")
            .HTMLBody = RangetoHTML(Rng) 'This RangetoHTML is a function as mentioned in below code
            '.Send 'is used to send e-mail
            .Display 'is used to save e-mail as draft item
        End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    ActiveWorkbook.CheckCompatibility = False
End Sub
Function RangetoHTML(Rng As Range) 'Rng here is ThisWorkbook.Worksheets("sheet1").Range("g6:i17")
     
    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) 'Create new excel file
    
    With TempWB.Sheets(1) 'Selecte Sheet 1 of the new file
        .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

Display More

jaslake · Sep 11th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi SAS83

This Code will delete all Controls (Form Controls, ActiveX Controls, Pictures, etc.) on the Worksheet.

The first Line of Code says that if there is an error because no Controls exist then skip the next two lines of Code.
The second line of Code says that if Controls do exist and they're hidden, make them visible.
The third line of Code says delete all of them.
The fourth line of Code is the bail out line for the first line of Code.

Code

On Error Resume Next
          .DrawingObjects.Visible = True
          .DrawingObjects.Delete 
        On Error Goto

SAS83 · Oct 7th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi jaslake, extremely sorry for late reply. Thanks a lot for the help. Have a nice day ahead.

jaslake · Oct 8th 2015

Re: Copy range, paste in outlook mail and send e-mail

You're welcome...glad I could help.

mcheshier · May 6th 2021

Quote from Gulam

Re: Copy range, paste in outlook mail and send e-mail

Hi, Try this.

HTML

Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Set rng = Nothing
    On Error Resume Next
     'Only the visible cells in the selection
    
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
     'You can also use a range if you want


    Set rng = Sheets("Sheet1").Range("C1:H25").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
        vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    strHtml = "<html>" & "<body>" & "Hi All," & "<br>" & "</br>" & "</body>" & "</html>"
         
    With OutMail
        .To = ""
        .CC = ""
        .Subject = "Test Mail""
        .HTMLBody = strHtml & RangetoHTML(rng)
        
         '.Send   'or use .Display
        .Display
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
       ActiveWorkbook.CheckCompatibility = False
  ActiveWorkbook.Save
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 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

Display More

Gulam, this worked like a charm! Thank you!!

However, it keeps deleting my email signature. Is there a way to keep the email signature? Thank you for the help.

Mark

iamnatecanlas · Apr 20th 2022

Hi,

I tried this code and it worked. Thanks!

Though, I would like to apply this in creating a calendar meeting invite where it will only open a calendar meeting invite then the email body will be captured from excel. Other details like recipient and dates can be supplied manually. My only concern is just the email body where it doesn't work on my end. Looking forward to hear from you for this case.

Sub Consolidation_Invite()

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

'Don't forget to copy the function RangetoHTML in the module.

'Working in Excel 2000-2016

Dim rng As Range

Dim OutApp As Object

Dim objMyApptItem As Object

Dim recipients As Range

Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error Resume Next

'Only the visible cells in the selection

Set rng = Sheets("Email").Range("B9:R23").SpecialCells(xlCellTypeVisible)

'You can also use a fixed range if you want

'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If rng Is Nothing Then

MsgBox "The selection is not a range or the sheet is protected" & _

vbNewLine & "please correct and try again.", vbOKOnly

Exit Sub

End If

With Application

.EnableEvents = False

.ScreenUpdating = False

End With

Set OutApp = CreateObject("Outlook.Application")

OutApp.Session.Logon

Set objMyApptItem = OutApp.CreateItem(1)

Set recipients = Worksheets("Email").Range("C4")

On Error Resume Next

strHtml = "<html>" & "<body>" & "Hi All," & "<br>" & "</br>" & "</body>" & "</html>"

With objMyApptItem

.MeetingStatus = olMeeting

.recipients.Add recipients

.Location = Worksheets("Email").Range("C7")

.Subject = Worksheets("Email").Range("C6")

'.Start = Worksheets("Calendar Invite").Range("B15")

.AllDayEvent = "False"

.HTMLBody = strHtml & RangetoHTML(rng)

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

' Changed by Ron de Bruin 28-Oct-2006

' Working in Office 2000-2013

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

Copy range, paste in outlook mail and send e-mail

Participate now!

Share