Excel Office 2016中的MailItem.GetInspector.WordEditor生成应用程序定义或对象定义的错误

我编写了一个Excel宏来从电子表格发送电子邮件。它适用于Office 2013，但不适用于Office 2016

我查看了Office 2013和2016之间的VBA差异，但看不到有关消息对象的检查器或word编辑器的任何更改

一旦它到达

.GetInspector.WordEditor

它就会抛出：

运行时错误“287”：
应用程序定义或对象定义错误

以下是宏的相关部分：

Sub SendEmail()
    Dim actSheet As Worksheet
    Set actSheet = ActiveSheet

    'directories of attachment and email template
    Dim dirEmail as String, dirAttach As String

    ' Directory of email template as word document
    dirEmail = _
        "Path_To_Word_Doc_Email_Body"

    ' Directories of attachments
    dirAttach = _
        "Path_To_Attachment"

    ' Email Subject line
    Dim subjEmail As String
    subjEmail = "Email Subject"

    Dim wordApp As Word.Application
    Dim docEmail As Word.Document

    ' Opens email template and copies it
    Set wordApp = New Word.Application
    Set docEmail = wordApp.Documents.Open(dirEmail, ReadOnly:=True)
    docEmail.Content.Copy

    Dim OutApp As Outlook.Application
    Set OutApp = New Outlook.Application
    Dim OutMail As MailItem
    Dim outEdit As Word.Document

    ' The names/emails to send to
    Dim docName As String, sendEmail As String, ccEmail As String, siteName As String
    Dim corName As String

    Dim row As Integer
    For row = 2 To 20

        sendName = actSheet.Cells(row, 1)
        sendEmail = actSheet.Cells(row, 2)
        ccEmail = actSheet.Cells(row, 3)
        siteName = actSheet.Cells(row, 4)

        Set OutMail = OutApp.CreateItem(olMailItem)
        With OutMail
            .SendUsingAccount = OutApp.Session.Accounts.Item(1)
            .To = sendEmail
            .CC = ccEmail
            .Subject = subjEmail & " (Site: " & siteName & ")"

            Set outEdit = .GetInspector.WordEditor
            outEdit.Content.Paste

            outEdit.Range(0).InsertBefore ("Dear " & sendName & "," & vbNewLine)

            .Attachments.Add dirAttach

            .Display
            '.Send

        End With
        Debug.Print row

        Set OutMail = Nothing
        Set outEdit = Nothing
    Next row

    docEmail.Close False
    wordApp.Quit
End Sub

我根据建议尝试过的事情：

• 选中Outlook设置-默认为HTML文本
• 在

  .GetInspector.WordEditor上移动
  .display

---

确保Word是默认的电子邮件编辑器。从：

只有当

IsWordMail

方法返回True且

EditorType

属性为

olEditorWord

时，

WordEditor

属性才有效。返回的

WordDocument

对象提供对大多数Word对象模型的访问

---

此外，请确保Outlook配置为发送富文本或HTML电子邮件，而不是纯文本。

我不能完全确定我是否有与您相同的问题，但升级Office 2016后，对

GetInspector

的呼叫开始失败。因此，明确地说，它与Office 2016一起工作，在最新更新后停止工作

以下变通方法对我有效

dim item : set item = Addin.Outlook.CreateItemFromTemplate(Filename)
Outlook.Inspectors.Add(item) ' Outlook is the application object

只有当我在创建项目之后直接添加该项目，在其上设置属性，然后添加该项目时，它才似乎起作用

---

注意：我没有使用

CreateItem

而不是

CreateItemFromTemplate

进行测试。在Office更新之前，第二行已添加且不必要。

尝试将编辑器移动到第一个操作。。。

…问题： 出于安全目的，HTMLBody、HTMLEditor、Body和WordEditor属性都受到地址信息安全提示的约束，因为邮件正文通常包含发件人或其他人的电子邮件地址。而且，如果组策略不允许，则这些提示不会出现在屏幕上。简单地说，作为开发人员，您必须更改代码，因为既不能更改注册表，也不能修改组策略

因此，如果您的代码在迁移到Office 365后突然停止工作或出于任何其他原因，请参考以下解决方案。为了便于理解和实施，添加了注释

解决方案1: 如果您具有管理权限，请尝试以下链接中给出的注册表更改：

但是，作为开发人员，我建议使用与所有版本的Excel兼容的代码，而不是进行系统更改，因为每个最终用户的机器上也需要进行系统更改

解决方案2:VBA代码 代码兼容：Excel 2003、Excel 2007、Excel 2010、Excel 2013、Excel 2016、Office 365

---

选项显式
子创建_电子邮件（ByVal strTo作为字符串，ByVal strSubject作为字符串）
变暗RNGTOPITURE As范围
Dim outlookApp作为对象
将邮件变暗为对象
将strTempFilePath设置为字符串
将strTempFileName设置为字符串
随便你说什么，都没关系
strTempFileName=“RangeAsPNG”
'rngToPicture在工作簿中定义为命名范围，请在使用前修改此名称
设置RNGTOPITURE=范围（“RNGTOPITURE”）
设置outlookApp=CreateObject（“Outlook.Application”）
Set-Outmail=outlookApp.CreateItem（olMailItem）
'创建电子邮件
发邮件
.To=strTo
.Subject=strSubject
'将范围创建为PNG文件并存储在临时文件夹中
调用createPNG（rngToPicture，strTempFileName）
'在Outlook中嵌入图像
strTempFilePath=Environ$（“temp”）&“\”&strTempFileName&“.png”
.Attachments.Add strTempFilePath，olByValue，0
'更改下面的HTML以使用换行符（
）添加标题（亲爱的John）或签名（亲切问候）
.HTMLBody=“”
.展示
以
发送邮件=无
Set-outlookApp=无
设置rngToPicture=Nothing
端接头
子createPNG（ByRef rngToPicture作为范围，nameFile作为字符串）
把我当作绳子
wksName=rngToPicture.Parent.Name
'删除同名的现有PNG文件（如果存在）
出错时继续下一步
Kill Environ$（“temp”）&“\”nameFile&“.png”
错误转到0
'将范围复制为图片
rngToPicture.CopyPicture
'将图片粘贴到相同尺寸的图表区域中
使用此工作簿。工作表（wksName）。图表对象。添加（rngToPicture.Left，rngToPicture.Top，rngToPicture.Width，rngToPicture.Height）
.激活
.Chart.Paste
'将图表作为PNG文件导出到临时文件夹
.Chart.Export环境$（“temp”）和“\”名称文件和“.png”、“png”
以
工作表（wksName）.ChartObjects（工作表（wksName）.ChartObjects.Count）.删除
端接头

您的Outlook电子邮件设置是什么--纯文本还是富文本/html？如果是纯文本。还要确保Word是默认的电子邮件编辑器（同一个线程提到）。@reply是的，我已经检查了这些设置，它们被设置为html。哪个操作系统在运行？我们在Windows 7上，这很奇怪。我看到了并检查了这两个属性，它们都是正确的：！在尝试处理检查器之前，请尝试添加一个

outEdit.Display

？或者可能是

.Show

，我记不起它叫什么了。它是Display，我将它移到了“.GetInspector.WordEditor”上方，仍然是同一个问题。奇怪。您的代码在2016年适用于我（使用后期绑定Outlook进行测试）。我注意到在屏幕截图中你的WordEditor是一个空对象，但我的显然是一个可以扩展的对象/文档。。。您是否确保为2016版Outlook和/或Word勾选了正确的参考号？如果Excel文件

     With OutMail

        Set outEdit = .GetInspector.WordEditor
        outEdit.Content.Paste

        .SendUsingAccount = OutApp.Session.Accounts.Item(1)
        .To = sendEmail
        .CC = ccEmail
        .Subject = subjEmail & " (Site: " & siteName & ")"

Option Explicit

Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)


    Dim rngToPicture As Range
    Dim outlookApp As Object
    Dim Outmail As Object
    Dim strTempFilePath As String
    Dim strTempFileName As String

    'Name it anything, doesn't matter
    strTempFileName = "RangeAsPNG"

    'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
    Set rngToPicture = Range("rngToPicture")
    Set outlookApp = CreateObject("Outlook.Application")
    Set Outmail = outlookApp.CreateItem(olMailItem)

    'Create an email
    With Outmail
        .To = strTo
        .Subject = strSubject

        'Create the range as a PNG file and store it in temp folder
        Call createPNG(rngToPicture, strTempFileName)

        'Embed the image in Outlook
        strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
        .Attachments.Add strTempFilePath, olByValue, 0

        'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
        .HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"


        .Display

    End With

    Set Outmail = Nothing
    Set outlookApp = Nothing
    Set rngToPicture = Nothing

End Sub

Sub createPNG(ByRef rngToPicture As Range, nameFile As String)

    Dim wksName As String

    wksName = rngToPicture.Parent.Name

    'Delete the existing PNG file of same name, if exists
    On Error Resume Next
        Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0

    'Copy the range as picture
    rngToPicture.CopyPicture

    'Paste the picture in Chart area of same dimensions
    With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        'Export the chart as PNG File to Temp folder
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete

End Sub