我正在尝试从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:" & "
" & RangetoHTML(rng1) _
& "
" & "Critical" & "
" & RangetoHTML(rng2) & "
" & "High" _
& "
" & RangetoHTML(rng3) & "
" & "Low" & "
" & RangetoHTML(rng4) _
& "
" & "Other" & "
" & RangetoHTML(rng5) _
& "
" & "Overdue" & "
" & RangetoHTML(rng6)
.Attachments.Add nPath '.FullName
.Recipients.ResolveAll
.Display '.Send
End With
我无法共享此代码的输出，但如上所述，会发生的事情是Excel工作表中的超链接不会传输到Outlook电子邮件 . 它们是蓝色的并带有下划线但没有超链接 .
如何将excel的活动超链接转移到outlook？我一直无法找到符合我特定需求的预先存在的解决方案 .
