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.
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