Outlook Hypperlink of fila in email body will not open

[josros60]

Hi,

I have the below code works fine only problem when emailing it and want to open the file Outlook only recognize part the of the link:

Attaching picture of what Outlook detect.
it only sees \\mtlnas01\EFT_Backup\2023\10 not the rest


Code

Sub Make_Outlook_Mail_With_File_Link()[IMG alt="Name:  hypperlink.png<br>Views: 2<br>Size:  12.2 KB"]https://www.excelforum.com/attachments/excel-programming-vba-macros/844950d1696536774-outlook-hypperlink-of-fila-in-email-body-will-not-open-hypperlink.png[/IMG]
'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-ONLINE PAYMENTS attched, listed below and 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("F4") & _
                  """>Link to the file</A>" & "<br><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("ONLINE_PAYMENTS").Range("ONLINEPYMT").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
            With OutMail
            .To = "afia.amaniampong@distributel.ca"
            .CC = "ricardo.alfaro@distributel.ca"
            .BCC = ""
            .Subject = "" & Range("SUBJECT").Value  'ActiveWorkbook.Name
            strbody = strbody & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:15'>" '& _
                      '"Hi" & ActiveSheet.Range("U1") & " " & ActiveSheet.Range("W1") & "," & "<br>" & "<br>" & "<br>" & "<br>" & _
                      '"<br>" & "<br>" & "Thank you,"
            .attachments.Add Application.ActiveWorkbook.FullName
            .attachments.Add Sheets("ONLINE_PAYMENTS").Range("F4").Value
            .Display   'or use .Send
            .HTMLBody = strbody & "<br>" & "<br>" & .HTMLBody
        End With
        On Error GoTo 0

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

End With
 End If
 
End Sub

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[ATTACH type="full"]99805[/ATTACH]

 

[josros60]

help, please.

Thank you,