从 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

现在 returns 287 运行时间错误“应用程序定义或对象定义的错误”。

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

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

我让它工作的唯一方法是运行直接在 Outlook VBA 上对代码应用签名。但我需要能够运行从 excel VBA.

有什么建议吗？

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

Answer 1

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

使用 Outlook 所基于的低级代码 - Extended MAPI 或围绕此 API 的任何其他第三方包装程序，例如 Redemption。
使用专为关闭 Outlook 中的此类安全触发器而设计的第三方组件 - Security Manager for Microsoft Outlook.
设置组策略以避免此类触发器。
在系统上安装有效的防病毒软件。

Answer 2

您可以通过搜索（Items.Restrict 或 Items.Find/FindNext）PidTagSenderSmtpAddress MAPI 属性（DASL 名称 http://schemas.microsoft.com/mapi/proptag/0x5D01001F).

此外，没有理由遍历商店 - Application.Session.GetDefaultFolder() 无论如何都会为您提供默认商店中的文件夹。

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

Retrieving the Sender’s email address from Outlook 365

excel

outlook

vba

digital-signature

office365