Pasting Range of Cells into Outlook with Other Text in Body?

**bryanmarks** · 06-04-2014, 01:33 PM

Hello! I am still looking for help with this code!

I've searched for how to do this, including on Ron De Bruin's website, and have yet to see how you can copy a range of cells in Excel from a file into the body of an email that already has text plus attach a separate file to the email. I'm sure it's doable, but I'm way too new at all of this to figure out the correct code to use.

The cells that need to be copied will always be in a file named SPSS CHECK--Daily ER Production Aggr by Region Type & ER.xlsx in columns A-K, but the number of rows in that range will vary by day. I've identified where I'd want these cells to be pasted in the code below, but with no attempt at coming up with the code for that.

BTW, is there a way to add a hard space at the end of sentences so that two spaces always appear between the end of one sentence and the beginning of another, or is that an Outlook quirk that strips out extra spaces and reformats the text?

Here is my code so far:

Sub SaveToDir()
ActiveWorkbook.Save

Dim wbk As Workbook
SaveDir = "F:\GroupShares\Employer Activity by Day\"
'See if today's date (Now) is a Monday or not.  If Monday, it runs the first SaveName code; otherwise, it runs the second SaveName code.
If (Weekday(Now(), 2) = 1) Then
    SaveName = "Daily Employer Production by Region, Manager, & Agent Report--" & Format(Now() - 3, "YYYY-MM-DD") & ".xlsx"
Else
    SaveName = "Daily Employer Production by Region, Manager, & Agent Report--" & Format(Now() - 1, "YYYY-MM-DD") & ".xlsx"
End If

 If Len(Dir(SaveDir & SaveName, vbDirectory)) > 0 Then 'Check to see if the file already exists
   Resp = MsgBox("File name: " & SaveName & vbCrLf & vbCrLf & "already exists in: " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
     If Resp = vbCancel Then
        Exit Sub
     End If
   For Each wbk In Workbooks             'Check to see if the file is open
     If wbk.Name = SaveName Then
        Resp2 = MsgBox(SaveName & " is open. Press OK to close the file or Cancel to abort", vbOKCancel)
     If Resp2 = vbOK Then
        Application.DisplayAlerts = False
        Workbooks(SaveName).Close
     Else
    Exit Sub
   End If
  End If
 Next
End If

ActiveWorkbook.Sheets.Copy  'Copy all sheets to a new workbook with no code modules
Set wbk = ActiveWorkbook    'Copied sheets in the new workbook
Application.DisplayAlerts = False
    wbk.Sheets("Sheet1").Delete
    wbk.SaveAs Filename:=SaveDir & SaveName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False     'Saves the new file
    MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)

Workbooks.Open Filename:="F:\GroupShares\Employer Activity by Day\SPSS CHECK--Daily ER Production Aggr by Region Type & ER.xlsx"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
Selection.Copy

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
    Workbooks(SaveName).Activate
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    strbody = "<HTML><BODY><p style='font-family:calibri;font-size:14.5'>" & "Hi, <br><br>" & _
"Here is the Daily Employer Production report for " & Application.Text(ActiveSheet.Range("D1"), "mmmm d, yyyy") & _
". " & " A summary of the production is below:  <br><br>" & _

'***********This is where I want the pasted cells from the file to go.****************

"If you have any questions regarding the accuracy of this report, please check to be sure numbers were entered correctly.  " & _
" If there are still problems, please contact me. <br><br>" & _
"Thanks,<br><br>Bryan<br></p>"
   On Error Resume Next
    With OutMail
        .to = "Person@MyDomain.com"
        .Subject = "Daily Employer Production Report for " & Application.Text(ActiveSheet.Range("D1"), "M/D/YYYY")
        .HTMLbody = strbody & .HTMLbody
        .Attachments.Add ActiveWorkbook.FullName   
        .Display 'or use .Send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
Application.DisplayAlerts = True
End Sub

**Tinbendr** · 06-05-2014, 01:52 PM

You have to generate a HTML string using Ron's function and 'build' a final string to assign to .HTMLBody.

    strbody = "<HTML><BODY><p style='font-family:calibri;font-size:14.5'>" & "Hi, <br><br>" & _
"Here is the Daily Employer Production report for " & Application.Text(ActiveSheet.Range("D1"), "mmmm d, yyyy") & _
". " & " A summary of the production is below:  <br><br>"

'Change range as needed.
Dim Rng As Range
Set Rng = Workbooks(SaveName).Range("A2:J10")
Dim strBodyRng As String
'Ron's range to html link
'http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
strBodyRng = RangetoHTML(Rng)

strbody = strbody & strBodyRng & "If you have any questions regarding the accuracy of this report, please check to be sure numbers were entered correctly.  " & _
" If there are still problems, please contact me. <br><br>" & _
"Thanks,<br><br>Bryan<br></p>"

**bryanmarks** · 06-06-2014, 05:33 PM

Hi, David,

Thanks for the suggestion! It got me much closer to where I wanted to be, but still needed a lot of additional code to do what I wanted. This included adding the Function RangetoHTML(rng As Range) code from Ron de Bruin's page, without which the code will never run. At first, I thought I wanted a block of cells that would be in another file to be copied and pasted into the email, then realized that could make a very long email, so I created a macro ("FindGrandTotal") to only pull the information on the Grand Total line plus the approprite column headers.

Here is what I ended up using. I'm hoping someone else out there will find it of some use. I'm picking it up where the

Dim OutApp As Object

is created. The Function RangetoHTML(rng As Range) code is shown below that.

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim strbody, strbody2, strBodyRng As String
FindGrandTotal
Set rng = Range("A1:D2")
strBodyRng = RangetoHTML(rng)
Sheets("Daily Production Aggr by Dist").Select
strbody = "<HTML><BODY><p style='font-family:calibri;font-size:14.5'>" & "Hi, <br><br>" & _
"Here is the Daily Production report for " & Application.Text(ActiveSheet.Range("B1"), "mmmm d, yyyy") & ".  " & _
" A summary of the production is below: "
strbody2 = "<HTML><BODY><p style='font-family:calibri;font-size:14.5'>If you have any questions regarding the accuracy of this report, please check to be sure numbers were entered correctly.  " & _
"If there are still problems, please contact me. <br><br>" & _
"Thanks,<br><br>" & "Bryan<br><br></p>"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .to = "Person@MyDomain.com"
        .Subject = "Daily Production Report for " & Application.Text(ActiveSheet.Range("B1"), "M/D/YYYY")
        .HTMLbody = strbody & strBodyRng & strbody2
        .Attachments.Add ActiveWorkbook.FullName
        .Display 'or use .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
    ActiveWindow.Close
Application.DisplayAlerts = True
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 paste 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).PasteSpecial xlPasteColumnWidths, , 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

    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=")

    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Sub FindGrandTotal()
    Cells.Find(What:="Grand Total", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
          SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Selection.End(xlToRight).Select
    Range(Selection, Selection.Offset(0, 5)).Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A2").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select
    
    Sheets("Daily Production").Select
    Range("E2:J2").Copy
    Sheets("Sheet2").Select
    ActiveSheet.Paste
    Range("A1:F2").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 11.5
    End With
    Columns("A:C").ColumnWidth = 10.86
    Columns("D:F").ColumnWidth = 13.14
    Range("A1").Select
End Sub