如何在“TO”部分以电子邮件地址格式获取电子邮件地址？

Question

我正在尝试获取已收到邮件的“收件人”部分中的所有电子邮件地址。

此代码为每个电子邮件地址提供一个链接。

"/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=636da3beeae34f2493a3ee2c93d44007-LC", 

其中 LC 是接收邮件的帐户的显示名称。

Sub openLeaseInbox()
    Dim oOutlook As Outlook.Application
    Dim oFolder As Outlook.Folder
    Dim oMailBox As String
    Dim oFldr As String
    Dim XDate As Date
    Dim i As Integer
    Dim olMail As Outlook.MailItem
    Dim olrecips As Outlook.Recipients
    Dim olrecip As Outlook.Recipient
    Dim LR As Integer
    Range("L2").Value = "3/20/2022"
    XDate = Format(ThisWorkbook.Sheets("Email Download").Range("L2").Value, "mm/dd/yyyy")
    Set oOutlook = CreateObject("Outlook.Application")
    Set oNS = oOutlook.GetNamespace("MAPI")
    oMailBox = "Lease QC"oFldr = "Inbox"
    Set oFolder = oNS.Folders(oMailBox).Folders(oFldr)
    If (oOutlook.ActiveExplorer Is Nothing) Then
        oFolder.Display
    Else
        Set oOutlook.ActiveExplorer = oFolder
    End If
    i = 1
    For Each olMail In oFolder.Items.Restrict("[ReceivedTime] < '" & XDate & "' ")
        Set olrecips = olMail.Recipients
        Range("A1").Offset(i, 0).Value = olMail.Subject
        Range("B1").Offset(i, 0).Value = olMail.ReceivedTime
        For Each olrecip In olrecips
            Range("C1").Offset(i, 0).Value = olrecip.Address   ' Seems there is a problem here'
        Next
        Range("D1").Offset(i, 0).Value = olMail.body
        i = i + 1
    Next olMail
End Sub

Answer 1

我使用函数解决了它。以下是供将来参考的完整工作代码。感谢您的帮助！！

Sub openLeaseInbox()

Dim oOutlook As Outlook.Application
Dim oFolder As Outlook.Folder
Dim oMailBox As String
Dim oFldr As String
Dim XDate As Date
Dim i As Integer
Dim olMail As Outlook.MailItem
Dim olrecips As Outlook.Recipients
Dim olrecip As Outlook.Recipient
Dim LR As Integer

Range("L2").Value = "4/3/2022"
XDate = Format(ThisWorkbook.Sheets("Total Data").Range("L2").Value, "mm/dd/yyyy")

Set oOutlook = CreateObject("Outlook.Application")
Set oNS = oOutlook.GetNamespace("MAPI")
oMailBox = "Lease QC"
oFldr = "Inbox"
Set oFolder = oNS.Folders(oMailBox).Folders(oFldr)

    If (oOutlook.ActiveExplorer Is Nothing) Then
        oFolder.Display
        Else
        Set oOutlook.ActiveExplorer = oFolder
    End If

i = 1

For Each olMail In oFolder.Items.Restrict("[ReceivedTime] > '" & XDate & "' ")
        Dim ToAddress As String
        Set olrecips = olMail.Recipients
        Range("A1").Offset(i, 0).Value = olMail.Subject
        Range("B1").Offset(i, 0).Value = olMail.ReceivedTime
        Range("C1").Offset(i, 0).Value = EmailAddressInfo(olMail)
        Range("D1").Offset(i, 0).Value = olMail.body
        i = i + 1
    
Next olMail

End Sub

Private Function EmailAddressInfo(olItem As MailItem) As Variant
    If olItem.Class <> olMail Then Exit Function
    
On Error GoTo ExitFunction
    
    Dim olRecipient As Outlook.Recipient
    Dim olEU As Outlook.ExchangeUser
    Dim olEDL As Outlook.ExchangeDistributionList
    Dim ToAddress, CCAddress, Originator, email As String
                
    For Each olRecipient In olItem.Recipients
       With olRecipient
            Select Case .AddressEntry.AddressEntryUserType
                Case olSmtpAddressEntry 'OlAddressEntryUserType.
                    email = .Address
                Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
                    Set olEDL = .AddressEntry.GetExchangeDistributionList
                    email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
                Case Else
                    Set olEU = .AddressEntry.GetExchangeUser
                    email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
            End Select
            If email <> "" Then
                Select Case .Type
                    Case olTo: ToAddress = ToAddress & email & ";"
                    Case olCC: CCAddress = CCAddress & email & ";"
                End Select
            End If
        End With
    Next
    EmailAddressInfo = Array(ToAddress, CCAddress)
ExitFunction:
End Function