我想在 Excel 中使用 VBA 从 Office 365 Outlook 邮件中读取 SenderAddress？

Question

我已尽一切努力从 Office 365 Outlook 阅读邮件，但无法阅读。每次发件人地址都是空的。 我得到的错误是： 运行时错误：“287” 应用程序定义或对象定义的错误。

请找到我正在使用的代码。

Option Explicit

Sub Mail()

    Dim xNameSpace As Outlook.Namespace
    Dim xFolder As Outlook.Folder
    Dim xOutlookApp As Outlook.Application
    
    Set xOutlookApp = New Outlook.Application
    Set xNameSpace = xOutlookApp.Session
    Set xFolder = xNameSpace.GetDefaultFolder(olFolderInbox)
    
    Set xFolder = xFolder.Folders("Retail")
        ' Set Outlook application object.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
    Dim objNSpace As Object     ' Create and Set a NameSpace OBJECT.
    ' The GetNameSpace() method will represent a specified Namespace.
    Set objNSpace = objOutlook.GetNamespace("MAPI")
    
    Dim myFolder As Object  ' Create a folder object.
    Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
    
    Dim objItem As Object
    Dim iRows, iCols As Integer
    iRows = 2

    ' Loop through each item in the folder.
    For Each objItem In xFolder.Items
        If objItem.Class = olMail Then
            Dim GetSenderAddress As String
            
            Dim objMail As Outlook.MailItem
            Set objMail = objItem
            
            Dim mailType As String
            mailType = objMail.SenderEmailType
            
            
            If mailType = "EX" Then
                ' GetSenderAddress = GetExchangeSenderAddressNew(objMail)
                FindAddress (objMail.SenderEmailAddress)
            Else
                GetSenderAddress = objMail.SenderEmailAddress
            End If

            Cells(iRows, 1) = objMail.SenderEmailAddress
            Cells(iRows, 2) = objMail.To
            Cells(iRows, 3) = objMail.Subject
            Cells(iRows, 4) = objMail.ReceivedTime
        End If
        iRows = iRows + 1
    Next
    Set objMail = Nothing
   
    ' Release.
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing

End Sub

Private Function GetExchangeSenderAddress(objMsg As MailItem) As String
    
    Dim oSession As Object
    Set oSession = CreateObject("MAPI.Session")
    oSession.Logon "", "", False, False
    
    Dim sEntryID As String
    Dim sStoreID As String
    Dim oCdoMsg As Object
    Dim sAddress As String
    Const g_PR_SMTP_ADDRESS_W = &H39FE001F
    
    sEntryID = objMsg.EntryID
    sStoreID = objMsg.Parent.StoreID
    Set oCdoMsg = oSession.GetMessage(sEntryID, sStoreID)
    
    sAddress = oCdoMsg.Sender.Fields(g_PR_SMTP_ADDRESS_W).Value
    Set oCdoMsg = Nothing
    oSession.Logoff
    Set oSession = Nothing
    
    GetExchangeSenderAddress = sAddress
    
End Function

另一个代码是：

Sub Mail()

    Dim jsObj As New ScriptControl
    
    jsObj.Language = "JScript"
    
    With jsObj
        .AddCode "outlookApp = new ActiveXObject('Outlook.Application'); nameSpace = outlookApp.getNameSpace('MAPI'); nameSpace.logon('','',false,false); mailFolder = nameSpace.getDefaultFolder(6); var Inbox = mailFolder.Folders; var box = Inbox.Item('Retail').Items;  "
    End With
    
    
End Sub

如果我可以在 Office 365 Outlook 中读取邮件的发件人地址，请告诉我。

Answer 1

首先，以下代码行遍历文件夹中的所有项目：

' Loop through each item in the folder.
For Each objItem In xFolder.Items
    If objItem.Class = olMail Then

您不检查它是收到还是组成的项目。撰写的电子邮件可能尚未设置与发件人相关的属性，因此您可以使用CurrentUser 属性，它将当前登录用户的显示名称作为Recipient 对象返回。

注意，如果配置了 Exchange 帐户，您可以使用 AddressEntry.GetExchangeUser 属性，如果 AddressEntry 属于 Exchange AddressList 对象（例如全局地址），则该属性返回代表 AddressEntry 的 ExchangeUser 对象列表 (GAL) 并对应于 Exchange 用户。

ExchangeUser.PrimarySmtpAddress 属性返回一个字符串，该字符串表示 ExchangeUser 的主要简单邮件传输协议 (SMTP) 地址。