如何将以回车分隔的Excel数据（多个单独范围）发送到Outlook邮件正文_Excel_Vba_Email_Outlook

如何将以回车分隔的Excel数据（多个单独范围）发送到Outlook邮件正文

excel vba email outlook

如何将以回车分隔的Excel数据（多个单独范围）发送到Outlook邮件正文,excel,vba,email,outlook,Excel,Vba,Email,Outlook,我正在尝试将excel文件的某些部分发送到Outlook邮件正文中我需要对数据进行格式化，因为我处理的是表内的数据以及不同的单元格填充颜色和字体颜色，所以不能将其存储在字符串中我需要回车符来分隔粘贴到outlook中的表格，以便可以手动将其他文本添加到表格之间的电子邮件正文中，而不会扭曲表格格式下面的代码显示了需要执行的操作，但由于返回运行时错误13，“.HTMLBody”行上的类型不匹配，因此无法工作。我花了很长时间尝试不同的方法来实现这一点，但这是我需要它的工作方式，我只是不知道要使用

我正在尝试将excel文件的某些部分发送到Outlook邮件正文中

我需要对数据进行格式化，因为我处理的是表内的数据以及不同的单元格填充颜色和字体颜色，所以不能将其存储在字符串中

我需要回车符来分隔粘贴到outlook中的表格，以便可以手动将其他文本添加到表格之间的电子邮件正文中，而不会扭曲表格格式

下面的代码显示了需要执行的操作，但由于返回运行时错误13，“.HTMLBody”行上的类型不匹配，因此无法工作。我花了很长时间尝试不同的方法来实现这一点，但这是我需要它的工作方式，我只是不知道要使用哪些数据类型以及如何正确地实现它

请记住，在下面的两个代码示例中，我都删除了粘贴的大部分数据范围，因为这是冗余代码

Sub sendToOutlook()
    Dim OutApp As Object
    Dim OutMail As Object

    Dim bodyFieldA As Range
    Dim bodyFieldB As Range

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Range("L18").Value
        .CC = Range("L19").Value
        .BCC = Range("L20").Value
        .Subject = Range("L1") & " " & Range("N1").Text _
                   & " " & Range("O1") & " " & Range("R1").Text _
                   & " " & Range("S1")

        Set bodyFieldA = Range("A26:I33")
        Set bodyFieldB = Range("A34:I34")

        .HTMLBody = bodyFieldA + vbCrLf + bodyFieldB + "<HTML><body><body></HTML>"
        .display
    End With

    Application.CutCopyMode = False
    Range("A1").Select

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Sub sendToOutlook（）
Dim OutApp作为对象
将邮件变暗为对象
暗淡的车身视野A作为范围
Dim BODYFIELD B As范围
出错时继续下一步
Set-OutApp=GetObject（，“Outlook.Application”）
如果错误为0，则设置OutApp=CreateObject（“Outlook.Application”）
错误转到0
Set-OutMail=OutApp.CreateItem（0）
发邮件
.To=范围（“L18”）.值
.CC=范围（“L19”）.值
.BCC=范围（“L20”）.值
.Subject=范围（“L1”）和范围（“N1”）。文本_
&范围（“O1”）和范围（“R1”）。文本_
&“&范围（“S1”）
设置bodyFieldA=范围（“A26:I33”）
设置bodyFieldB=范围（“A34:I34”）
.HTMLBody=bodyFieldA+vbCrLf+bodyFieldB+“”
陈列
以
Application.CutCopyMode=False
范围（“A1”）。选择
发送邮件=无
设置应用程序=无
端接头

我的旧版本只有在Outlook已经被用户设置了一次焦点的情况下才有效，否则我使用的“sendkeys”（而不是回车）会被发送到excel，从而破坏工作表数据

此外，如果“.TO”字段留空，“sendkeys”将发送到此处而不是电子邮件正文

我需要解决这个问题，所以上面的代码是我尝试解决它的方法，而下面的代码是我的老代码，它做了这项工作，但是有很多的带帮助工作和问题，经验不足的用户将使用宏无法处理。

Sub sendToOutlook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Range("L18").Value
        .CC = Range("L19").Value
        .BCC = Range("L20").Value
        .Subject = _
            Range("L1") & " " & Range("N1").Text _
            & " " & Range("O1") & " " & Range("R1").Text _
            & " " & Range("S1")

        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range

        'force html format
        .HTMLBody = "<HTML><body><body></HTML>"
        .display

        oRng.collapse 1
        Range("A26:I33").Select
        Selection.Copy
        oRng.Paste
        SendKeys "{ENTER}", True

        oRng.collapse 1
        Range("A34:I34").Select
        Selection.Copy
        oRng.Paste
        SendKeys "{ENTER}", True
    End With

    'deselect cell range
    Application.CutCopyMode = False
    Range("A1").Select

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub

Sub sendToOutlook（）
Dim OutApp作为对象
将邮件变暗为对象
作为对象的对象
Dim wdDoc作为对象
作为物体的暗角
出错时继续下一步
Set-OutApp=GetObject（，“Outlook.Application”）
如果错误为0，则设置OutApp=CreateObject（“Outlook.Application”）
错误转到0
Set-OutMail=OutApp.CreateItem（0）
发邮件
.To=范围（“L18”）.值
.CC=范围（“L19”）.值
.BCC=范围（“L20”）.值
.主题=_
范围（“L1”）和范围（“N1”）。文本_
&范围（“O1”）和范围（“R1”）。文本_
&“&范围（“S1”）
设置olInsp=.GetInspector
设置wdDoc=olInsp.WordEditor
设置oRng=wdDoc.范围
'强制html格式
.HTMLBody=“”
陈列
突然崩溃1
范围（“A26:I33”）。选择
选择，复制
装饰膏
SendKeys“{ENTER}”，真
突然崩溃1
范围（“A34:I34”）。选择
选择，复制
装饰膏
SendKeys“{ENTER}”，真
以
'取消选择单元格范围
Application.CutCopyMode=False
范围（“A1”）。选择
发送邮件=无
设置应用程序=无
设置olInsp=Nothing
设置wdDoc=Nothing
设为零
端接头

在上面的第二组代码中，我将表格复制粘贴到基于Word的电子邮件正文中，我得到了以下代码。基本上，在粘贴表格之前，我们用几个CrLf“启动”文档

Option Explicit

Sub sendToOutlook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Range("L18").Value
        .CC = Range("L19").Value
        .BCC = Range("L20").Value
        .Subject = _
            Range("L1") & " " & Range("N1").Text _
            & " " & Range("O1") & " " & Range("R1").Text _
            & " " & Range("S1")

        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range

        'force html format
        .HTMLBody = "<HTML><body><body></HTML>"
        .display

        '--- start with two CrLf's, so we can add the first table
        '    in between them...
        oRng.InsertAfter vbCrLf & vbCrLf

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up one character (so that the table inserts before the CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -1
        Range("A26:I33").Select
        Selection.Copy
        oRng.Paste

        '--- finally move the cursor all the way to the end and paste the
        '    second table
        Set oRng = wdDoc.Range
        oRng.collapse 0
        Range("A34:I34").Select
        Selection.Copy
        oRng.Paste
        'SendKeys "{ENTER}", True
    End With

    'deselect cell range
    Application.CutCopyMode = False
    Range("A1").Select

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub

选项显式
子sendToOutlook（）
Dim OutApp作为对象
将邮件变暗为对象
作为对象的对象
Dim wdDoc作为对象
作为物体的暗角
出错时继续下一步
Set-OutApp=GetObject（，“Outlook.Application”）
如果错误为0，则设置OutApp=CreateObject（“Outlook.Application”）
错误转到0
Set-OutMail=OutApp.CreateItem（0）
发邮件
.To=范围（“L18”）.值
.CC=范围（“L19”）.值
.BCC=范围（“L20”）.值
.主题=_
范围（“L1”）和范围（“N1”）。文本_
&范围（“O1”）和范围（“R1”）。文本_
&“&范围（“S1”）
设置olInsp=.GetInspector
设置wdDoc=olInsp.WordEditor
设置oRng=wdDoc.范围
'强制html格式
.HTMLBody=“”
陈列
'---从两个CrLf开始，这样我们可以添加第一个表
“在他们之间。。。
vbCrLf和vbCrLf后面的插入符号
'---现在重新选择整个文档，将光标折叠到末尾
'并备份一个字符（以便表在CrLf之前插入）
设置oRng=wdDoc.范围
oRng.0
开始，移动1，-1
范围（“A26:I33”）。选择
选择，复制
装饰膏
“---最后将光标一直移动到末端并粘贴
“第二张桌子
设置oRng=wdDoc.范围
oRng.0
范围（“A34:I34”）。选择
选择，复制
装饰膏
'SendKeys“{ENTER}”，True
以
'取消选择单元格范围
Application.CutCopyMode=False
范围（“A1”）。选择
发送邮件=无
设置应用程序=无
设置olInsp=Nothing
设置wdDoc=Nothing
设为零
端接头
下面的代码解决了我的两个问题。多亏了彼得，他给了我一个策略
Sub sendToOutlook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Range("L18").Value
        .CC = Range("L19").Value
        .BCC = Range("L20").Value
        .Subject = _
            Range("L1") & " " & Range("N1").Text _
            & " " & Range("O1") & " " & Range("R1").Text _
            & " " & Range("S1")

        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range

        'force html format
        .HTMLBody = "<HTML><body><body></HTML>"
        .display

        '--- start with 6 CrLf's, so we can place each table
        '    above all but the last used...
        oRng.InsertAfter vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up six characters (so that the table inserts before the FIRST CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -6
        Range("A1:I8").Select
        Selection.Copy
        oRng.Paste

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up five characters (so that the table inserts before the SECOND CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -5
        Range("A9:I9").Select
        Selection.Copy
        oRng.Paste

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up four characters (so that the table inserts before the THIRD CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -4
        Range("A11:I22").Select
        Selection.Copy
        oRng.Paste

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up three characters (so that the table inserts before the FOURTH CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -3
        Range("A24:I24").Select
        Selection.Copy
        oRng.Paste

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up two characters (so that the table inserts before the FIFTH CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -2
        Range("A26:I33").Select
        Selection.Copy
        oRng.Paste

        '--- now reselect the entire document, collapse our cursor to the end
        '    and back up one character (so that the table inserts before the SIXTH CrLf)
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Move 1, -1
        Range("A34:I34").Select
        Selection.Copy
        oRng.Paste


        '--- finally move the cursor all the way to the end and paste the
        '    second table BELOW the SIXTH CrLf
        Set oRng = wdDoc.Range
        oRng.collapse 0
        Range("A36:I47").Select
        Selection.Copy
        oRng.Paste
    End With

    'deselect cell range
    Application.CutCopyMode = False
    Range("A1").Select

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing

End Sub

Sub sendToOutlook（）
Dim OutApp作为对象
作为Obj发送邮件