如何将 Excel 数据（多个单独的范围）以回车符 returns 分隔发送到 Outlook 邮件正文
How do I send Excel data (multiple individual ranges) seperated by carriage returns to an Outlook mail body
我正在尝试将 excel 文件的某些部分发送到 Outlook 邮件正文中。
我需要数据的格式，因为我在 tables 中处理数据并且使用不同的单元格填充颜色和字体颜色，所以它不能存储在字符串 AFAIK 中。
我需要回车 returns 来分隔粘贴到 outlook 中的 table，以便可以在 table 之间手动将其他文本添加到电子邮件正文中，而不会扭曲table 格式化。
下面的代码显示了需要完成的工作，但无法正常工作 returns 运行时错误 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
我的旧版本只有在 Outlook 已经被用户给予焦点一次时才有效，否则我使用 "sendkeys" 而不是回车 returns 被发送到 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
根据上面的第二组代码，将表格复制粘贴到基于 Word 的电子邮件正文中，我得出了以下代码。基本上，在粘贴表格之前，我们 "priming" 带有几个 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
下面的代码解决了我的两个问题。感谢 PeterT 给了我一个使用策略。
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
我正在尝试将 excel 文件的某些部分发送到 Outlook 邮件正文中。
我需要数据的格式，因为我在 tables 中处理数据并且使用不同的单元格填充颜色和字体颜色，所以它不能存储在字符串 AFAIK 中。
我需要回车 returns 来分隔粘贴到 outlook 中的 table，以便可以在 table 之间手动将其他文本添加到电子邮件正文中，而不会扭曲table 格式化。
下面的代码显示了需要完成的工作，但无法正常工作 returns 运行时错误 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
我的旧版本只有在 Outlook 已经被用户给予焦点一次时才有效，否则我使用 "sendkeys" 而不是回车 returns 被发送到 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
根据上面的第二组代码，将表格复制粘贴到基于 Word 的电子邮件正文中，我得出了以下代码。基本上，在粘贴表格之前，我们 "priming" 带有几个 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
下面的代码解决了我的两个问题。感谢 PeterT 给了我一个使用策略。
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