Sending a Range in Outlook

[Emily A]

Hi there! I am very new to VBA so everything I have put in this code has been borrowed from other individuals questions, and I am having trouble making the last few adjustments for it to fit my needs. I am trying to send an email with a range of cells copied from an Excel workbook. I made the code and have verified I can send an email with just a general body message and I can make the correct selection of cells in my code, but when I try and change the body of my email to include the cells I have issues. I think this has to do with the mail body variable designation, but I get a "type mismatch" error when I try and change it to a range from string when I was just sending a practice email. Any help is appreciated! Thank you!

Sub SendEmail(what_address As String, subject_line As String, mail_body As Range)
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send
End Sub

Sub CopyData()
Dim a As Long
Dim i As Long
Dim b As Long
Dim r As Long
Dim mail_body As Range
Dim what_address As String
Dim subject_line As String


Application.ScreenUpdating = False
a = Worksheets("Active").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Active").Cells(2, "B").Copy Worksheets("Sheet3").Cells(1, "A")
Worksheets("Active").Cells(2, "E").Copy Worksheets("Sheet3").Cells(1, "B")
Worksheets("Active").Cells(2, "F").Copy Worksheets("Sheet3").Cells(1, "C")
Worksheets("Active").Cells(2, "O").Copy Worksheets("Sheet3").Cells(1, "D")
Worksheets("Active").Cells(2, "Y").Copy Worksheets("Sheet3").Cells(1, "E")

For i = 2 To a
If Worksheets("Active").Cells(i, 3).Value = "Michael" Then

b = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("Active").Cells(i, "B").Copy Worksheets("Sheet3").Cells(b + 1, "A")
Worksheets("Active").Cells(i, "E").Copy Worksheets("Sheet3").Cells(b + 1, "B")
Worksheets("Active").Cells(i, "F").Copy Worksheets("Sheet3").Cells(b + 1, "C")
Worksheets("Active").Cells(i, "O").Copy Worksheets("Sheet3").Cells(b + 1, "D")
Worksheets("Active").Cells(i, "Y").Copy Worksheets("Sheet3").Cells(b + 1, "E")
End If
Next i

r = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet3").Activate
ActiveSheet.Range(Cells(1, 1), Cells(r, 5)).Select
Set mail_body = Selection

what_address = "example@gmail.com"
subject_line = "Test"


Call SendEmail(what_address, subject_line, mail_body)

'Sheets("Sheet3").UsedRange.ClearContents
Application.ScreenUpdating = True
End Sub

 

[daverunt]

Hi,

I would go to the following site and use that method to mail a selected range.

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Alternatively, but not as tidy, a range of rows/columns can be concatenated into a string, which you could use.
You would need to change the DIM and the mail_body As Range to As String in the sub also

.........

ActiveSheet.Range(Cells(1, 1), Cells(r, 5)).Select

 'Set mailBody = Selection

 LastRow = Selection.Rows.Count

For r = 1 To LastRow
For c = 1 To 5   'columns A to E
For Each cell In Cells(r, c)
strtable = strtable & "     " & cell.Value
Next
Next
strtable = strtable & vbNewLine
Next
 
mail_body = strtable

what_address = "example@gmail.com"

 

[Emily A]

Hi daverunt,

Thanks for your response! I actually came across that webpage this morning and tried to modify my code to work with it. I am not having any errors when running it, and the email that displays has it going to the correct email address and has the proper subject line but has no text in the body. Any idea as to where I might be going wrong?

Sub CopyData()
    Dim a As Long
    Dim i As Long
    Dim b As Long
    Dim r As Long
    Dim rng As Range
    Dim StrBody As String
        
    Application.ScreenUpdating = False
a = Worksheets("Active").Cells(Rows.Count, 1).End(xlUp).Row 'find how many rows have data
        Worksheets("Active").Cells(2, "B").Copy Worksheets("Sheet3").Cells(1, "A")
        Worksheets("Active").Cells(2, "E").Copy Worksheets("Sheet3").Cells(1, "B")
        Worksheets("Active").Cells(2, "F").Copy Worksheets("Sheet3").Cells(1, "C")
        Worksheets("Active").Cells(2, "O").Copy Worksheets("Sheet3").Cells(1, "D")
        Worksheets("Active").Cells(2, "Y").Copy Worksheets("Sheet3").Cells(1, "E")
        
For i = 2 To a 'for each row between 2 and the final row with data
    If Worksheets("Active").Cells(i, 3).Value = "Michael " Then 
       
        b = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
        
        Worksheets("Active").Cells(i, "B").Copy Worksheets("Sheet3").Cells(b + 1, "A")
        Worksheets("Active").Cells(i, "E").Copy Worksheets("Sheet3").Cells(b + 1, "B")
        Worksheets("Active").Cells(i, "F").Copy Worksheets("Sheet3").Cells(b + 1, "C")
        Worksheets("Active").Cells(i, "O").Copy Worksheets("Sheet3").Cells(b + 1, "D")
        Worksheets("Active").Cells(i, "Y").Copy Worksheets("Sheet3").Cells(b + 1, "E")
    End If 
Next i

r = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Nothing
On Error Resume Next
Worksheets("Sheet3").Activate
ActiveSheet.Range(Cells(1, 1), Cells(r, 5)).Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)
StrBody = "This is line 1" & "<br>" & _
            "This is line 2" & "<br>" & _
            "This is line 3" & "<br><br><br>"
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
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "example@gmail.com"
.CC = ""
.BCC = ""
.Subject = "This is a test"
.HTMLBody = StrBody & RangetoHTML(rng)
.Display  '.Send
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)
    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
        Applicaton.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

Thank you!!

 

[daverunt]

I had the same issue.
Stepping through the code it exits in the function at the

Applicaton.CutCopyMode = False and jumps to display the message, which is blank at this point.


I copied the RangetoHtml code directly from Ron's site and pasted it as is and it worked.
Put your RangetoHtml code in from your post and it fails.
Did you change anything in it? I didn't look.
Perhaps you introduced an unwanted character on one of the lines.

 

[daverunt]

Found some changes.

You should copy and paste!

TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"      ' this line is missing a backslash

Applicaton.CutCopyMode = False   ' application is missing an 'i'

Copy and paste this working version:

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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

 

[Emily A]

Thank you so much!!

 

[daverunt]

Glad it's working and hope you visit MrExcel in the future.