电子邮件 Excel 范围：将范围转换为带有超链接的 HTML

Question

我正在使用 Ron de Bruin的RangetoHTML 来自动化复制Excel中的区域并粘贴到Outlook邮件正文中。 但是，原始代码只粘贴数值，而我的区域包含具有超链接的单元格。 我尝试了一些在线解决方案，但它们都没有生效。其中这一个添加了一个部分来复制链接。它给我一个运行时错误"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，它会复制链接，但其他所有内容都变成了零。

  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

如何将数值和超链接一起复制到电子邮件中？这似乎是一个简单的修复，但我已经花了几天时间，仍然没有成功。感激任何帮助！我使用的是Excel2016。

- Ace_J

Answer 1

复制所有内容对我有效。

我部分重构了你的代码，使其更加简洁，但是还有几个改进可以做。

请查看注释并根据需要进行调整。

---

编辑：更改了创建HTML的方式，从复制值到直接从源文件导出工作表和范围

编辑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

- Ricardo Diaz

---

谢谢您的评论！然而，我可以使用PasteAll复制链接，但我会失去所有其他数据。请查看我的编辑以获取屏幕截图。 - Ace_J

此外，该公式从所选范围之外的单元格中提取数据。我猜这可能是它无法复制的原因，但我不知道如何修复它。 - Ace_J

请查看我的修改 #2 - Ricardo Diaz

代码看起来不太稳定。在.Publish处它有8/10的概率给我返回“对象publishobject的方法publish失败”的错误，只有2次是手动在代码编辑器中运行时成功的。 - Ace_J

以下是一些可能的解决方案：https://www.mrexcel.com/board/threads/method-publish-of-object-publishobject-failed.69377/ - Ricardo Diaz