Email from Excel query

[gmazza76]

Good afternoon

I have some VB that sends an email to people but I need to add a hyperlink to the body of an email with a range pasted into the body as well.
Ive looked about the internet and can see how people have amended code to send links to web pages but not a file location on the network.

Would this be possible as I am send out data to be checked in the body of the email and would like them to update the link that is in the email but it always errors.

I am using the following code, but the file wont open and the path is correct.

thanks in advance

Dim OutApp, OutMail As Object
Dim MakeJPG, AgentName, TLEmail, AgentEmail, Reason, Outcome, Marker, xStrBody  As String
Dim rng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
    

    AgentName = Worksheets("Sheet1").Range("G4").Value
    TLName = Worksheets("Sheet1").Range("B2").Value
    Name2 = Worksheets("Sheet1").Range("B12").Value
    Email2 = Worksheets("Sheet1").Range("B13").Value
    CaseId = Worksheets("Sheet2").Range("C4").Value

    xStrBody = "Please follow " & " ,a href=" & " ******shareddrive access name*****"" Here</a> to update your response" & "<br>"
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set rng = Nothing
    On Error Resume Next
    
    Set rng = Sheets("Email Template").Range("S5:S39").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

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = TLEmail
        .CC = CXEmail
        .BCC = CheckerEmail
        .Subject = "raised " & AgentName & " CaseID " & CaseId & ". "
        .HTMLBody = xStrBody & RangetoHTML(rng)
        .send
    End With
    On Error GoTo 0

  
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
Application.ScreenUpdating = True
    
End Sub
Function RangetoHTML(rng As Range)
'Email on Save BLMOHC link to first portion of email above
Dim fso, 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 xlPasteColumnWidths
        .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