电子邮件 Excel 范围：范围至 HTML，带有超链接
Email Excel Range: Range to HTML with Hyperlinks
我正在使用 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。它给我一个运行时错误“5”，无效的过程调用或参数。在 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
我也尝试将 PasteSpecial xlPasteValues 更改为 xlPasteAll，它复制了 link 但其他所有内容都变为零
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
如何将值和 hyperlinks 复制到电子邮件中？这感觉很容易解决，但我花了几天时间解决它，但没有成功。任何帮助表示赞赏！我用的是Excel2016.
复制全部对我有用。
我部分重构了您的代码以使其更简洁，但还有更多改进可以完成。
请查看评论并根据您的需要进行调整
编辑： 更改了 html 的创建方式，从复制值到直接导出 sheet 和源文件的范围
** 编辑 2** 更改了这一行：'更改了这一行：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
我正在使用 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。它给我一个运行时错误“5”，无效的过程调用或参数。在 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
我也尝试将 PasteSpecial xlPasteValues 更改为 xlPasteAll，它复制了 link 但其他所有内容都变为零
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
如何将值和 hyperlinks 复制到电子邮件中？这感觉很容易解决，但我花了几天时间解决它，但没有成功。任何帮助表示赞赏！我用的是Excel2016.
复制全部对我有用。
我部分重构了您的代码以使其更简洁，但还有更多改进可以完成。
请查看评论并根据您的需要进行调整
编辑： 更改了 html 的创建方式，从复制值到直接导出 sheet 和源文件的范围
** 编辑 2** 更改了这一行：'更改了这一行：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