Solved

Macro to email a selected range to list of recipients from excel 2010

Posted on 2013-01-06
5
639 Views
Last Modified: 2013-01-30
I want to create a macro that would select a range in the spreadsheet and then email it to a recepient or recepients thru Outlook, and then close the Outlook and return to the spread sheet.
0
Comment
Question by:hpjethwa
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
5 Comments
 
LVL 17

Expert Comment

by:Kent Dyer
ID: 38749836
Something like this?

http://www.cpearson.com/excel/Email.aspx

HTH,

Kent
0
 
LVL 16

Expert Comment

by:theo kouwenhoven
ID: 38750346
You even can do it without Outlook,
Create the mail in a file and use a Telnet session to send.
0
 
LVL 9

Accepted Solution

by:
TazDevil1674 earned 500 total points
ID: 38750427
Try the code below.  I have the code in a Module and have assigned the macro to a button on the sheet...

I also have a Recipients sheet, where I can specify the person(s) for the TO:, CC: and Send on Behalf of fields as required

Sub SendEmail()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngToEmail As Range, rngToCell As Range, strToEmail As String
Dim rngCCEmail As Range, rngCCCell As Range, strCCEmail As String
Dim Rng As Range
Dim ButtonChosen As Integer

ButtonChosen = MsgBox("Do you want to send Rota as " & Sheets("Recipients").Range("E2") & "?", vbQuestion + vbYesNo + vbDefaultButton2, "Continue?")

Set Rng = Nothing
On Error Resume Next
'Select Correct Sheet Name and Range
Set Rng = Sheets("Sheet to Email Name").Range("A1:J19") '.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

'set sheet to find address for e-mails as I have several people to mail to
'TO Field
Set rngToEmail = Sheets("Recipients").Range("A2:A51")
For Each rngToCell In rngToEmail.Cells
strToEmail = strToEmail & ";" & rngToCell.Value
Next
'CC Field
Set rngCCEmail = Sheets("Recipients").Range("C2:C51")
For Each rngCCCell In rngCCEmail.Cells
strCCEmail = strCCEmail & ";" & rngCCCell.Value
Next

With aEmail
    'set Importance
    .Importance = 2
    'Set Subject
    .Subject = Emailed Sheet and HTML
    'Set Body for mail
    .HTMLBody = "<p style='font-family:calibri;font-size:14'>" & _
        "Please see below for the HTML Version of my select cells from Excel." & _
        "</p><BR>" & _
        RangetoHTML(Rng)
    'Set attachment - un comment this if you want the whole spreadhseet attached too
    '.Attachments.Add ActiveWorkbook.FullName
    'Set Recipient
    .To = strToEmail
    .CC = strCCEmail
    'or send one off to 1 person use this static code
    '.Recipients.Add "E-mail.address-here@ntlworld.com"
    'send on behalf of
    If ButtonChosen = vbYes Then
        .SentOnBehalfOfName = Sheets("Recipients").Range("E2")
    Else
    End If
    'Send Mail
    .Display
    '.Send
End With

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") & ".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:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Open in new window

0
 
LVL 59

Expert Comment

by:LeeTutor
ID: 38838390
I've requested that this question be deleted for the following reason:

Not enough information to confirm an answer.
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

While working, an annoying popup showing below will come and we cannot cancel or close it form the screen. The error message will come again and again.
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

738 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question