VBA将Excel范围作为未格式化的Unicode文本粘贴到Outlook正文中？

Question

如何将 Excel 范围作为纯文本粘贴到 Outlook 电子邮件中 ​​- 我不想要格式，也不想要表格对象。这相当于复制 3 列和 2 行的范围并打开 Outlook 电子邮件正文并执行 Ctrl + Alt + V 并选择选择性粘贴为未格式化的 Unicode 文本。

下面的 sn-p 是将范围粘贴为 HTML 的流行代码。

Sub Mail_Selection_Range_Outlook_Body(sendTo As String, emailSub As String, rangeBody As Range)

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
Set rng = rangeBody

On Error GoTo 0

If rng 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 OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = sendTo
    .CC = ""
    .Subject = emailSub
    .HTMLBody = RangetoHTML(rng)
    .Display   'or use .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Answer 1

省略表格对象将要求您必须指定每列的字符数。

样本数据

输出

测试

Sub testTextTableEmail()
    Dim mailItem As Object, Source As Range
    Dim Body As String
    With Worksheets("Sheet1")
        Set Source = .Range("A1:G15")
    End With

    Body = getRangeTextTable(Source, 20, 10, 10, 10, 10, 10, 10)
    Set mailItem = getMailItem

    If Not mailItem Is Nothing Then
        With mailItem
            .to = ""
            .CC = ""
            .Subject = ""
            .HTMlBody = Body
            .Display
            '.Send
            '.Save
        End With
    End If

End Sub

功能

Function getRangeTextTable(Source As Range, ParamArray ColumnCharCounts() As Variant) As String
    Dim c As Long, n As Long
    Dim cell As Range
    Dim result() As String
    ReDim result(Source.Count + Source.Rows.Count)

    For Each cell In Source
        n = n + 1
        result(n) = Space(ColumnCharCounts(c))
        LSet result(n) = cell.Value

        c = c + 1
        If c > UBound(ColumnCharCounts) Then
            c = 0
            n = n + 1
            result(n) = vbNewLine
        End If
    Next
    getRangeTextTable = "<pre>" & Join(result) & "</pre>"
End Function

Function getMailItem() As Object
    Dim mailApp As Object, mailItem As Object
    Dim Body As String
    On Error Resume Next
    Set mailApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    If mailApp Is Nothing Then
        MsgBox "Could not create Outlook.Application", vbCritical, "Acton Cancelled"
        Exit Function
    End If

    On Error Resume Next
    Set mailItem = mailApp.CreateItem(0)
    On Error GoTo 0

    If mailItem Is Nothing Then
        MsgBox "Could not create Outlook.MailItem", vbCritical, "Acton Cancelled"
        Exit Function
    End If

    Set getMailItem = mailItem
End Function