4

我编写了一个 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
4

4 回答 4

3

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

仅当方法返回 True 且属性为时，该WordEditor属性才有效。返回的对象提供对大多数 Word 对象模型的访问...IsWordMailEditorTypeolEditorWordWordDocument

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

于 2017-07-28T14:59:45.420 回答
1

我不完全确定我是否遇到与您相同的问题，但是GetInspector在升级 Office 2016 后对我的调用开始失败。所以要明确的是，它与 Office 2016 一起工作，然后在最新更新后停止工作。

以下解决方法对我有用

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

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

注意：我没有测试过，CreateItem而不是CreateItemFromTemplate. 第二行是在 Office 更新之前添加的，并且没有必要。

于 2017-09-21T08:59:04.957 回答
1

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

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

解决方案 1： 如果您具有管理权限，请尝试以下链接中给出的注册表更改：https: //support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-设置在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
于 2020-06-03T00:45:45.033 回答
0

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

     With OutMail

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

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

...

于 2018-08-01T04:07:57.407 回答