自 Office 365 升级后 VBA 中的 MailItem.Send 无法正常工作

Posted 2023-02-19

【中文标题】自 Office 365 升级后 VBA 中的 MailItem.Send 无法正常工作

【英文标题】：MailItem.Send in VBA not functioning since Office 365 upgrade

【发布时间】：2018-10-26 10:08:41

【问题描述】：

我们在整个组织中发送了很多电子表格，为了尽可能地自动化，我们编写了一些代码来自动发送并允许我们仍然放入正文。

这个特殊的脚本从我们的财务系统 (SAP) 中提取信息，将其转储到 Excel 中并通过电子邮件发送给用户，它会循环多次下载并每次通过电子邮件发送不同的数据。

这在我们的旧 Windows 7 (Office 2010) 机器上运行良好，但我们中的一些人已经获得了新的 Windows 10 (Office 365) 机器进行试验。

代码运行时没有任何错误消息，但是当它到达 .Send 时，它直接跳转到 End Sub 并且不发送电子邮件。

我已经尝试过 EmailItem.Display，您可以看到电子邮件被填充，然后在桌面上保持可见，因为它循环浏览了其余的电子邮件。

关于如何解决这个问题的任何想法？我可以使用 application.send 功能，但我希望能够将自定义文本添加到电子邮件正文中。

谢谢:)

Sub EmailData()

Dim OL As Object
Dim EmailItem As Object
Dim y As Long
Dim TempChar As String
Dim Bodytext As String
Dim Flds As Variant
Dim EmailText As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Email Download to nursery

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.Createitem(OLMailItem)


'Check File Name is correct
Filename = Range("A1") & ".xls"
For y = 1 To Len(Filename)
    TempChar = Mid(Filename, y, 1)
    Select Case TempChar
    Case Is = "/", "\", "*", "?", """", "<", ">", "|"
    Case Else
        SaveName = SaveName & TempChar
    End Select
Next y
ActiveSheet.Cells.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
With ActiveWindow
    .DisplayGridlines = False
    .DisplayZeros = False
End With
Range("A1:S38").Select
Selection.Locked = True
Selection.FormulaHidden = False
Set EmailText = ActiveSheet.Range("AB1:AB5").SpecialCells(xlCellTypeVisible)

ActiveSheet.Protect ("keepsafe")
ActiveWorkbook.SaveAs Networkpath & "\" & SaveName, , "", , True
ActiveWorkbook.ChangeFileAccess xlReadOnly


 EmailItem.display

'On Error Resume Next
With EmailItem
.To = "[e-mail]"
'.To = Range("AA1")
.CC = ""
.BCC = ""
.Subject = Filename
.htmlBody = RangetoHTML(EmailText)
.Attachments.Add ActiveWorkbook.FullName

.send
End With

Application.Wait (Now + TimeValue("0:00:02"))

Kill Networkpath & "\" & SaveName
ActiveWorkbook.Close False


Set OL = Nothing
Set EmailItem = Nothing

End Sub

【问题讨论】：

你是说你得到了一个异常，但即使注释掉了“'On Error Resume Next”你也看不到它是什么？

即使删除了“On Error Resume Next”也是正确的，它会直接跳转到 End Sub。它无法发送电子邮件并保持当前工作簿打开。然后它会回到原来的 Sub 并继续循环到下一批数据。

快速更新，我来到了我们使用的另一个电子表格，它在 Excel 中具有相同的电子邮件代码。在“With EmailItem”之前插入“On Error Goto 0”时，我在尝试 .Send 时确实遇到了错误。我收到了旧的运行时 287 应用程序定义或对象定义错误。这可能是由于 Outlook 中不同的信任中心设置或更严格的安全性造成的吗？我注意到我们的 ICT 人员已将我们的信任中心设置锁定为高安全性，而该设置过去是低安全性的。

如果 .Send 被禁用，您可能会冒着使用 SendKeys 绕过安全性的风险。 ***.com/a/48105643/1571407

【参考方案1】：

这描述了在某些情况下，您可以如何“使对象模型充分发挥作用”。

NameSpace.Logon Method (Outlook)

“首先，实例化 Outlook 应用程序对象，然后引用默认文件夹，例如收件箱。这具有初始化 MAPI 以使用默认配置文件并使对象模型完全正常工作的副作用。”

Sub InitializeMAPI ()

    ' Start Outlook.
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    ' Get a session object. 
    Dim olNs As Outlook.NameSpace
    Set olNs = olApp.GetNamespace("MAPI")

    ' Create an instance of the Inbox folder. 
    ' If Outlook is not already running, this has the side
    ' effect of initializing MAPI.
    Dim mailFolder As Outlook.Folder
    Set mailFolder = olNs.GetDefaultFolder(olFolderInbox)

    ' Continue to use the object model to automate Outlook.
End Sub

【参考方案2】：

出于安全考虑，HTMLBody、HTMLEditor、Body 和 WordEditor 属性都受地址信息安全提示的约束，因为邮件正文通常包含发件人或其他人的电子邮件地址。

HKCU\Software\Policies\Microsoft\office\16.0\outlook\security\

提示地址簿访问 提示oom地址信息访问

https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

最可能的原因是 Outlook 安全性。

您可以在 HKCU\Software\Policies\Microsoft\office\16.0\outlook\security 中找到安全配置 （将 16.0 更改为您的 office 版本）

将 promptoomsend 更改为 2（或询问您的系统管理员），重新启动 Outlook 并重试。

更多信息https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo