?
Solved

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

Posted on 2013-01-06
5
Medium Priority
?
739 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
4 Comments
 
LVL 17

Expert Comment

by:Kent Dyer
ID: 38749836
Something like this?

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

HTH,

Kent
0
 
LVL 17

Expert Comment

by:Murphey
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 2000 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: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

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

Are you looking to start a business? Do you own and operate a small company? If so, here are some courses you need to take before you hire a full-time IT staff.
I tried to use the SharePoint app to Import a Spreadsheet and import an Excel sheet into a Team site made in SharePoint 2016. But that just resulted in getting an error message 'Unknown Error'...
If you’ve ever visited a web page and noticed a cool font that you really liked the look of, but couldn’t figure out which font it was so that you could use it for your own work, then this video is for you! In this Micro Tutorial, you'll learn yo…
Do you want to know how to make a graph with Microsoft Access? First, create a query with the data for the chart. Then make a blank form and add a chart control. This video also shows how to change what data is displayed on the graph as well as form…

601 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