Question

我正在尝试从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？我一直无法找到符合我特定需求的预先存在的解决方案。

Answer 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

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

1 个答案: