+ Reply to Thread
Results 1 to 3 of 3

Copy Range with Headers to Outlook Email

Hybrid View

  1. #1
    Forum Contributor
    Join Date
    12-11-2012
    Location
    Guadalajara, Mexico
    MS-Off Ver
    Excel 2007 & 2013
    Posts
    101

    Copy Range with Headers to Outlook Email

    Hello,

    I have a sample file attached and was wondering the most effective way to create a macro that would send an email with a range in the body of the email.

    The email has to do with deduction people will be getting and its like this.

    In column H is the list of email addresses, the range on the body of the email is on the same row but from columns C through G and should always include the headers.

    Can someone please help with this?
    Last edited by Leith Ross; 10-23-2019 at 08:52 PM.

  2. #2
    Forum Contributor
    Join Date
    12-11-2012
    Location
    Guadalajara, Mexico
    MS-Off Ver
    Excel 2007 & 2013
    Posts
    101

    Re: Copy Range with Headers to Outlook Email

    I found this code and modified it to add email body and it does not run for some reason:

    Please advise on what I may be doing wrong:

    Sub Send_Row_Email_Macro()
    '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-2013
        Dim OutApp As Object
        Dim OutMail As Object
        Dim cell As Range
        Dim rng As Range
        Dim Ash As Worksheet
        Dim StrBody As String
        
        Set Ash = ActiveSheet
        On Error GoTo cleanup
        Set OutApp = CreateObject("Outlook.Application")
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        
        StrBody = "Hello " & cel.Offset(, -1) & "<br>" & "<br>" & _
                  "We regret to inform you that there was an issue with ..." & "<br>" & _
                  "processed correctly.  In order to rectify this situation, make adjustment(s) in the subsequent " & "<br>" & _
                  "you will not experience a big hit to your time:" & "<br>" & "<br>" & _
                  "Please Check Proposed Adjustment Schedule below" & "<br>" & _
                  "Please contact us should you have any questions." & "<br>" & "<br>" & _
                  "Again, our sincere apologies for the mishaps with any inconvenience this may have caused you." & "<br><br><br>"
    
        For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
            If cell.Value Like "?*@?*.?*" _
               And LCase(cell.Offset(0, 1).Value) = "yes" Then
    
                'Change the filter range and filter Field if needed
                'It will filter on Column B now (mail addresses)
                Ash.Range("A1:J200").AutoFilter Field:=2, Criteria1:=cell.Value
    
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With
    
                Set OutMail = OutApp.CreateItem(0)
    
                On Error Resume Next
                With OutMail
                    .To = cell.Value
                    .Subject = "Benefit Deductions"
                    .HTMLBody = StrBody & RangetoHTML(rng)
                    .Display  'Or use .Send
                End With
                On Error GoTo 0
    
                Set OutMail = Nothing
                Ash.AutoFilterMode = False
            End If
        Next cell
    
    cleanup:
        Set OutApp = Nothing
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    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

  3. #3
    Forum Contributor
    Join Date
    12-11-2012
    Location
    Guadalajara, Mexico
    MS-Off Ver
    Excel 2007 & 2013
    Posts
    101

    Re: Copy Range with Headers to Outlook Email

    Ok I solved it: I was putting the strBdy in the wrong place

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Find the range of a table & copy/past into body of an Outlook email
    By JamesGilchrist in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 05-28-2014, 08:44 PM
  2. Copy Range of Data from Excel into Outlook Email
    By Vlade777 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 01-28-2014, 10:07 AM
  3. send selected range in email with default outlook email signature included
    By mdsickler in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 04-04-2013, 10:50 PM
  4. export email headers to excel from outlook
    By Rainnstar in forum Outlook Programming / VBA / Macros
    Replies: 0
    Last Post: 08-03-2012, 05:42 PM
  5. Replies: 2
    Last Post: 08-01-2012, 02:47 PM

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1