电子邮件 Excel 范围：范围到带有超链接的 HTML

Question

我正在使用Ron de Bruin's RangetoHTML 自动发送一封电子邮件，该电子邮件会将范围从 excel 复制到 Outlook 邮件正文。但是，原始代码仅粘贴值，但我的范围包含带有超链接的单元格。我尝试了一些我在网上找到的解决方案，但都没有奏效。 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，它复制了链接但其他所有内容都变为零

  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。

Answer 1

复制一切对我有用。

我对您的代码进行了部分重构以使其更简洁，但还有一些改进可以做。

请检查 cmets 并根据您的需要进行调整

---

编辑：将创建 html 的方式从复制值更改为直接从源文件导出工作表和范围

** EDIT 2** Changed this line: ' CHANGED THIS LINE: 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