Missing hyperlinks when exporting from excel to email

Question

So I just starting working with this, am a beginner. I made a macro that allows me to export my excel sheet to an email but when doing this my hyperlinks are not exported. Anyone has any ideea how to fix this? Here is my code:

Sub Mail_Selection_Range_Outlook_Body()

'Working in Excel 2000-2016 Dim rng As Range Dim OutApp As Object Dim OutMail As Object

Set rng = Nothing
On Error Resume Next

Set rng = Selection.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 = "[email protected]"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .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)

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"

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


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 savechanges:=False


Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

Maria Maria Maria Maria · Accepted Answer · 2018-04-23T12:51:05

Hey guys I found the solution, code below :

Sub Mail_Selection_Range_Outlook_Body()

'Working in Excel 2000-2016 Dim rng As Range Dim OutApp As Object Dim OutMail As Object

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("YourSheet").Range("D4:D12").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 = "[email protected]"
    .CC = ""
    .BCC = ""
    .Subject = "[Orwell][REPORT][QC] Activities Quick-Check - Orwell-Game-Main-"
    .HTMLBody = RangetoHTML(rng)
    .Display   'or use .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)

' Working in Office 2000-2016 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook 'new Dim Hlink As Hyperlink

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

    'Copy hyperlinks as well
For Each Hlink In rng.Hyperlinks
    ' relativeRange = TempWB.Sheets(1).Range(Hlink.Range.Address)

    TempWB.Sheets(1).Hyperlinks.Add _
        Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
        Address:=Hlink.Address, _
        TextToDisplay:=Hlink.TextToDisplay
Next Hlink

'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

Missing hyperlinks when exporting from excel to email

2 Answers