Question

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

我查看了Office 2013和2016之间的VBA差异，但看不到有关对邮件对象的检查器或字编辑器所做的更改。

一旦它到达.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文本
移动.display超过.GetInspector.WordEditor

Answer 1

确保Word是默认的电子邮件编辑器。来自Inspector.WordEditor dox：

WordEditor属性仅在IsWordMail方法返回True且EditorType属性为olEditorWord时才有效。返回的WordDocument对象提供对大多数Word对象模型的访问...

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

Answer 2

我不完全确定我是否遇到了与您相同的问题，但在升级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更新之前添加了第二行并且没有必要。

Answer 3

尝试将编辑器移至第一个操作... ...

     With OutMail

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

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

...

Answer 4

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

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

解决方案1： 如果您具有管理权限，请尝试以下链接中给出的注册表更改： https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

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

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

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

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

4 个答案: