Excel vba: Range to mail body - hyperlink cut

Question

I´m using a modified Ron De Bruin´s code to call an outlook mail window with a table made from range. In the range there´re some cell which contain link on a our company´s sharepoint. When the created table is inserted in the mail body, the hyperlinks in cells are somehow shortened from the beginning, so the adress starts simple with two dots (literally). I was wondering if the function could be modified in order to keep the whole link adress or after inserting the table in the mail body the ".." in the adresses could be removed by the regular beginning of the adress, which is always the same?

Sub create_mail()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng      As Range
    Dim OutApp   As Object
    Dim OutMail  As Object
    Dim lastrow  As Long
    Dim today    As Date
    Dim copies   As String
    Dim cell    As Range

'    get names of "responsible persons" to receive a copy
    lastrow = Range("b" & Rows.Count).End(xlUp).Row
    For Each cell In Range("g2:g" & lastrow)
        copies = copies & cell.Value & ";"
        Next cell


'    Create borders around the table
    Set rng = Range("a1:j" & lastrow)
    With rng.Borders
            .LineStyle = xlContinuous
            .Color = vbBlack
            .Weight = xlThin
            End With

'    macro will work faster
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'    save the file on sharepoint
    ActiveWorkbook.SaveAs Filename:= _
        "sharepoint_adress" & Format(Date, "mmddyyyy") & "_Agenda.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'create a mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "yo mama"
        .CC = copies
        .BCC = ""
        .Subject = "blah blah blah " & Format(Date, "mmddyyyy")
        .HTMLBody = RangetoHTML(rng)
        .Display
    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)
' 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 xlPasteAll, , False, False
        .Cells(1).PasteSpecial xlPasteAll, , 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

Excel vba: Range to mail body - hyperlink cut

Answers (1)

Related Questions