我试图将Excel文件的某些部分发送到Outlook邮件正文中。
我需要格式化数据，因为我正在使用表格内的数据以及不同的单元格填充颜色和字体颜色，所以它不能存储在字符串AFAIK中。
我需要使用回车来分隔粘贴到Outlook中的表，以便可以在表之间手动将其他文本添加到电子邮件正文中，而不会扭曲表格格式。
下面的代码显示了需要完成的工作但不会工作，因为它返回运行时错误13，在＆＃34; .HTMLBody＆＃34;上键入不匹配线。我花了很长时间尝试不同的方法来做到这一点，但这是我需要它工作的方式我只是不知道使用哪种数据类型以及如何正确地执行它。
请记住，在下面我的代码的两个示例中，我都删除了大部分数据范围，因为它将是冗余代码。
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已经被用户一次关注时才有效，否则＆＃34; sendkeys＆＃34;我使用而不是回车符被发送到excel，破坏了工作表数据。
另外，如果＆＃34; .TO＆＃34;字段留空了＆＃34; sendkeys＆＃34;被发送到那里而不是电子邮件正文。
我需要解决这个问题，所以上面的代码是我试图找到它的解决方案，而下面的代码是我的旧代码，它完成了这项工作，但有很多创可贴工作和问题经验较少的用户将使用宏将无法处理。
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
答案 0 :(得分：0)
从上面的第二组代码中，将表格复制粘贴到基于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
答案 1 :(得分：0)
下面的代码解决了我的两个问题。感谢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