从Outlook 365检索发件人的电子邮件地址

Question

以下代码从W7上的Office 2010升级到W10上的Office 365后停止工作。

Option Explicit

Sub test()

    Dim OL As Outlook.Application
    Dim ST As Outlook.Store
    Dim DSI As Outlook.Folder
    Dim Email As Outlook.MailItem

    Set OL = CreateObject("Outlook.Application")

    'Find Primary Mailbox
    For Each ST In OL.GetNamespace("MAPI").Stores
        If ST.ExchangeStoreType = olPrimaryExchangeMailbox Then
            Set DSI = ST.GetDefaultFolder(olFolderSentMail)
            Exit For
        End If
        Set ST = Nothing
    Next

    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    For Each Email In DSI.Items
        Debug.Print Email.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
    Next

    Set Email = Nothing
    Set DSI = Nothing
    Set ST = Nothing
    Set OL = Nothing

End Sub

它现在在此行上返回287运行时错误“应用程序定义的错误或对象定义的错误”。

Debug.Print Email.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)

我的研究表明，这是一个信任问题；因此我尝试在代码中添加签名，但这没有用。

我使它起作用的唯一方法是直接在Outlook VBA上运行并且将签名应用于代码。但是我需要能够从excel VBA中运行它。

有什么建议吗？

该代码的目的是在默认的“发送邮件”文件夹中标识已与共享邮箱一起发送的电子邮件，并将它们移动到一个单独的文件夹（上面的代码已被缩减以仅显示当前的错误）。正如我所说的，代码在升级之前运行良好。

Answer 1

似乎Microsoft对Outlook Automation实施了安全规则。您可以通过以下路线前往：

1. 使用Outlook所基于的低级代码-扩展MAPI或围绕此API的任何其他第三方包装程序，例如“兑换”。

2. 使用旨在在Outlook中关闭此类安全触发器的第三方组件-Security Manager for Microsoft Outlook。

3. [设置组策略以避免此类触发。

4. 在系统上设置有效的防病毒软件。