Email body not showing using html.

[josros60]

Have the code below to show range body of email working fine but now the beginning on cell "W1" saying Please process EFT don't know how to fix it using:

.HTMLBody = RangetoHTML(rng) & "" & Email_body

here is the complete code:

Sub Make_Outlook_Mail_With_File_Link()
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim rng As Range
    Dim Email_body As String
     
    If ActiveWorkbook.Path <> "" Then
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        strbody = "<font size=""3"" face=""Calibri"">" & _
                  "Hi Afia,<br><br>" & _
                  "<br>" & _
                   "Please process DCL-EFT saved on:" & "</B><br><br>" & _
                  "Link to open the file: " & _
                  "<A HREF=""file://" & ActiveWorkbook.FullName & _
                  """>Link to the file</A>" & "</B> <br> <br>" & _
                  "" & "</B><br>" & _
                  "Link to open the backup: " & _
                  "<A HREF=""file://" & NetworkPath & ActiveWorkbook.ActiveSheet.Range("E3") & _
                  """>Link to the file</A>""<br><br>" & _
                  "<br><br><span style=""font-family: Calibri; font-size: 16pt; font-weight: bold; color: #2cba00"">Note: The EFT backup link is on the spreadsheet as well....</span>" & _
                  "<br><br>Thank you," & _
                  "<br><br></font>"
                  '"<br><br>[span style=""font-family: Verdana; font-size: 24pt; font-weight: bold; color: #ff0000""]Note: The EFT backup link is on the spreadsheet as well....[/span]"Note: The EFT backup link is on the spreadsheet as well...."[span style=""font-family: Verdana; font-size: 24pt; font-weight: bold; color: #ff0000""] & _
                  '"<br><br>Thank you," & _
                  '"<br><br></font>"
                  
         Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("EFT Summary").Range("EFTSUMMARY").SpecialCells(xlCellTypeVisible)
    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

        On Error Resume Next
        With OutMail
            .To = "ricardo.alfaro@distributel.ca"
            .CC = ""
            .BCC = ""
            .Subject = "" & Range("SUBJECT2").Value  'ActiveWorkbook.Name
            .Email_body = "<p style='font-family:calibri;font-size:15'>" & "Hi" & " " & ActiveSheet.Range("W1") & "," & "<br>" & "<br>" & "<br>" & "<br>" & "<br>" & "<br>" & "Thank you,"
            .attachments.Add Application.ActiveWorkbook.FullName
            .attachments.Add Sheets("EFT Summary").Range("E3").Value
            '.HTMLBody = strbody
            .HTMLBody = RangetoHTML(rng) & "" & Email_body
            .Display   'or use .Send
        End With
        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
    Else
        MsgBox "The ActiveWorkbook does not have a path, Save the file first."
    End If

thank you

 

[Logit]

Here's an example to view :

Option Explicit

Sub SendEmail()
    Dim rng As Range, OutApp As Object, OutMail As Object
    Dim sCC As String, sSubj As String, sEmAdd As String
    
     '// Change the values of these variables to suit
    sEmAdd = "abc@abc.com"
    sCC = ""
    sSubj = "My Subject"
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = ActiveSheet.Cells(1).CurrentRegion
    On Error GoTo 0
    
    With Application
        .EnableEvents = 0
        .ScreenUpdating = 0
        .Calculation = xlCalculationManual
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = sEmAdd
        .CC = sCC
        .Subject = sSubj
        .HTMLBody = RangetoHTML(rng)
        '.Send '// Change this to .Display if you want to view the email before sending.
        .display
    End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = 1
        .Calculation = xlCalculationAutomatic
    End With
    Set OutMail = Nothing: Set OutApp = Nothing
    
End Sub
 
Function RangetoHTML(rng As Range)
    Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String
    Dim SendingRng As Range
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Set SendingRng = Worksheets("Sheet1").Range("A1:D10")                          ' ' <--- Change range here !!!
    SendingRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    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 0
    Kill TempFile
    
    Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing
    
End Function

Internxt Drive – Private & Secure Cloud StorageDownload :

 

[josros60]

Thank you.

 

[Logit]

You are welcome.