Email Excel Range: Range to HTML with Hyperlinks-CodePudding

I'm using Ron de Bruin's RangetoHTML to automate an email which copies a range from excel to outlook mail body. However, the original code only paste values, but my range contains cells with hyperlinks. I have tried a few solutions I found online but none of them worked. This one adds a section to copy the links. It gives me a runtime error "5", invalid procedure call or argument. Added section in RangetoHTML.

Private Sub EmailProjectTeam_Click()

Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim emailRng As Range
Dim copyRng1 As Range
Dim xEmailAddr As String
Dim xTxt As String
Dim strbody As String
Dim signature As String

On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set emailRng = Sheets("Team Setup").Range("D:D")
If emailRng Is Nothing Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In emailRng
    If xCell.Value Like "*@*" Then
        If xEmailAddr = "" Then
            xEmailAddr = xCell.Value
        Else
            xEmailAddr = xEmailAddr & ";" & xCell.Value
        End If
    End If
Next

Set copyRng1 = Sheets("Email").Range("C1:P13").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
 If copyRng1 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 xMItem = xOTApp.CreateItem(0)
 

With xMItem
 .Display
    .To = xEmailAddr
    .Subject = ""
    .HTMLBody = RangetoHTML(copyRng1)
    .Display
    '.Send
 End With
 On Error GoTo 0
 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"

'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).PasteSpecial xlPasteAll
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'------- added section to copy links
Dim Hlink As Hyperlink
For Each Hlink In rng.Hyperlinks
    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

I also tried to change PasteSpecial xlPasteValues to xlPasteAll, it copies the link but everything else becomes zero

  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, changed PasteSpecial
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).PasteSpecial xlPasteAll
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

How can I copy both values and hyperlinks into an email? It feels like an easy fix but I have spent couple days on it with no luck. Any help is appreciated! I'm using Excel2016.

CodePudding user response：

Copying All worked for me.

I partly refactored your code to make it more clean, but there are several more improvements that can be done.

Please check the comments and adjust it to fit your needs

EDIT: Changed the way the html is created from copying the values to exporting directly the sheet and range from the source file

** EDIT 2** Changed this line: ' CHANGED THIS LINE: Source:=bodyRange.Parent.UsedRange.Address

Private Sub EmailProjectTeam_Click()
    
    On Error GoTo SafeFail
    
    ' Turn off stuff (speed up process)
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    ' Set reference to target Sheet
    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.Worksheets("Team Setup")
    
    ' Find last cell in column D
    Dim lastRow As Long
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "D").End(xlUp).Row
    
    ' Set the email range
    Dim emailRange As Range
    Set emailRange = targetSheet.Range("D2:D" & lastRow)
    
    ' Exit if range is nothing
    If emailRange Is Nothing Then Exit Sub
    
    ' Get the email addresses // This could be done with a filter, but it's not the point of your question
    Dim sourceCell As Range
    For Each sourceCell In emailRange.Cells
        If sourceCell.Value Like "*@*" Then
            Dim emailAddr As String
            If emailAddr = vbNullString Then
                emailAddr = sourceCell.Value
            Else
                emailAddr = emailAddr & ";" & sourceCell.Value
            End If
        End If
    Next
    
    ' Get the body range
    Dim bodyRange As Range
    Set bodyRange = ThisWorkbook.Worksheets("Email").Range("C1:P13").SpecialCells(xlCellTypeVisible)
    
    If bodyRange 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

    ' Initialize Outlook
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")


    ' Prepare the new email
    Dim outlookMail As Object
    Set outlookMail = outlookApp.CreateItem(0)
    
    ' Set email content and properties
    With outlookMail
        .Display
        .To = emailAddr
        .Subject = ""
        .HTMLBody = RangetoHTML(bodyRange)
        .Display
        '.Send
    End With
    On Error GoTo 0

SafeExit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

SafeFail:
    MsgBox Err.Description
    GoTo SafeExit

End Sub

Private Function RangetoHTML(bodyRange As Range) As String

    Dim tempFilePath As String
    tempFilePath = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Publish the sheet to a htm file
    With ThisWorkbook.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=tempFilePath, _
         Sheet:=bodyRange.Parent.Name, _
         Source:=bodyRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from the htm file into RangetoHTML
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim ts As Object
    Set ts = fso.GetFile(tempFilePath).OpenAsTextStream(1, -2)
    
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Delete the htm file we used in this function
    Kill tempFilePath

    Set ts = Nothing
    Set fso = Nothing

End Function