将 Excel 范围内的超链接传输到 Outlook 电子邮件

Posted 2023-02-19

【中文标题】将 Excel 范围内的超链接传输到 Outlook 电子邮件

【英文标题】：Transfer Hyperlinks in Excel Range to Outlook Email

【发布时间】：2018-08-07 09:04:16

【问题描述】：

我正在尝试从 excel 范围（rng 1 到 6）创建一封电子邮件，其中 A 列和 D 列中的每个单元格都有超链接。下面是为这些范围创建超链接的代码示例。一切正常。

ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("A" & D2), _
Address:="some address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value 

ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("D" & D2), _
Address:="some other address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value

然后，我使用以下代码从 excel 范围（rng1 到 6）创建电子邮件。创建电子邮件时，超链接不会传输到 Outlook。文本带有下划线，好像有一个超链接，但它不可点击。

Sub Mail_Body()
Dim rng1 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim wb2 As Workbook
Dim MyDate, Weeknr, MyFileName, MyTime, MyMonth
Dim Mail1 As String
Dim Mail2 As String
Dim Subject As String
Dim Warr As String
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim Subject_email As String

Application.ScreenUpdating = False
Application.EnableEvents = False

nPath = Environ("temp") & "\" & ThisWorkbook.Sheets("Lists").Range("AA1").Value
Set wb2 = Workbooks.Open(nPath)

D2 = Sheets("Critical").Range("A1").Offset(Sheets("Critical").Rows.Count - 1, 0).End(xlUp).Row
D3 = Sheets("High").Range("A1").Offset(Sheets("High").Rows.Count - 1, 0).End(xlUp).Row
D4 = Sheets("Low").Range("A1").Offset(Sheets("Low").Rows.Count - 1, 0).End(xlUp).Row
D5 = Sheets("Other").Range("A1").Offset(Sheets("Other").Rows.Count - 1, 0).End(xlUp).Row
D6 = Sheets("Overdue").Range("A1").Offset(Sheets("Overdue").Rows.Count - 1, 0).End(xlUp).Row

Set rng = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Set rng5 = Nothing
Set rng6 = Nothing

Set rng2 = Sheets("Critical").Range("A1:J" & D2).SpecialCells(xlCellTypeVisible)
Set rng3 = Sheets("High").Range("A1:J" & D3).SpecialCells(xlCellTypeVisible)
Set rng4 = Sheets("Low").Range("A1:J" & D4).SpecialCells(xlCellTypeVisible)
Set rng5 = Sheets("Other").Range("A1:J" & D5).SpecialCells(xlCellTypeVisible)
Set rng6 = Sheets("Overdue").Range("A1:L" & D6).SpecialCells(xlCellTypeVisible)

Set OutMail = Nothing
Set OutApp = Nothing

On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
'MsgBox OutApp
Set OutMail = OutApp.CreateItem(0)

Dim Session As Object
Set Session = OutApp.GetNamespace("MAPI")
Session.Logon

Create email
With OutMail
    .To = Mail1
    .CC = Mail2
    .BCC = ""
    .Subject = Subject_email
    .htmlBody = "Overview:" & "<br>" & RangetoHTML(rng1) _
       & "<br>" & "<u>Critical</u>" & "<br>" & RangetoHTML(rng2) & "<br>"   & "<u>High</u>" _
        & "<br>" & RangetoHTML(rng3) & "<br>" & "<u>Low</u>" & "<br>" &  RangetoHTML(rng4) _
        & "<br>" & "<u>Other</u>" & "<br>" & RangetoHTML(rng5) _
        & "<br>" & "<u>Overdue</u>" & "<br>" & RangetoHTML(rng6)
    .Attachments.Add nPath '.FullName
    .Recipients.ResolveAll
    .Display  '.Send
End With

我无法共享此代码的输出，但是如上所述，Excel 工作表中的超链接不会传输到 Outlook 电子邮件。它们是蓝色的并带有下划线，但没有超链接。 如何将活动超链接从 excel 转移到 Outlook？我一直无法找到适合我特定需求的现有解决方案。

【问题讨论】：

如果您分享数据的 ab 示例，也许成品应该是什么样子，以及您的自定义功能的解释，以及表明您至少 尝试自己解决这个问题。有数百个（如果不是数千个）网页（和代码示例）详细说明如何在 Excel 中使用超链接。另外，请参阅 these tips 以及 minimal reproducible example 和 [tips]。

我不能真正分享输出。如前所述，outlook 中的最终输出应该具有 A 列和 D 列中所有单元格的活动超链接，这些超链接是从 excel 中继承的。代码运行良好，没有错误，因此所有内容都在电子邮件正文中。只是那里没有超链接。如果我附上这张图片，它看起来就像解释的一样。是的，我已经四处寻找这个特定问题的答案，但没有成功。我会继续寻找，但真的希望有人能理解这个问题并能有所启发。谢谢

什么是 RangetoHTML？您添加了哪个参考来使用它？或者你定义的代码是什么？

【参考方案1】：

我找到了解决问题的方法：https://www.mrexcel.com/forum/excel-questions/560111-retain-hyperlinks-after-rangetohtml-paste-outlook.html

在 RangetoHTML 函数中，将 .pastevalues 更改为 .pasteall，超链接将被复制。

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long

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 xlPasteFormats, , False, False
    .Cells(1).PasteSpecial xlPasteRowHeights
    .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