通过 VBA 在 Excel 中获取收件人和抄送列表中的电子邮件

Question

我在 VBA 编码方面的经验为零，但我目前有一个我在网上复制的有效代码，它成功地从每封电子邮件中提取了某些细节。我想知道是否可以补充或修改代码以包括收件人的电子邮件地址以及抄送列表中的电子邮件地址。代码如下-

Sub FetchEmailData()

Dim appOutlook As Object

Dim olNs As Object

Dim olFolder As Object

Dim olItem As Object

Dim iRow As Integer

' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.getnamespace("MAPI")
'Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason

Set olFolder = olNs.session.PickFolder

' Clear
ThisWorkbook.ActiveSheet.Cells.Delete

' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")

    For iRow = 1 To olFolder.items.Count
        Cells(iRow + 1, 1) = olFolder.items.Item(iRow).Sender
        Cells(iRow + 1, 2) = olFolder.items.Item(iRow).To
        Cells(iRow + 1, 3) = olFolder.items.Item(iRow).CC
        Cells(iRow + 1, 4) = olFolder.items.Item(iRow).receivedtime
        
        If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
             Cells(iRow + 1, 5) = olFolder.items.Item(iRow).Sender.GetExchangeUser().PrimarySmtpAddress
        Else
On Error Resume Next

            Cells(iRow + 1, 5) = olFolder.items.Item(iRow).SenderEmailAddress
        End If
        
    Next iRow


End Sub

Answer 1

您可以使用 Recipients 属性获取 Outlook 中特定邮件项目的所有收件人。 Recipient.Type property returns or sets a long representing the type of recipient. For mail items values are shown in the OlMailRecipientType enumeration:

olBCC - 3 - 收件人在项目的 BCC 属性中指定。
olCC - 2 - 收件人在项目的 CC 属性中指定。
olOriginator - 0 - Originator 项目的（发件人）。
olTo - 1 - 收件人在项目的 To 属性中指定。

所以，你可能会找到CC字段对应的Recipient对象，并使用Recipient.AddressEntry 属性其中returns AddressEntry对象对应的resolved收件人。

Set myAddressEntry = myRecipient.AddressEntry

AddressEntry.Address property returns or sets a string representing the email address of the AddressEntry. In case of Exchange accounts you may use the AddressEntry.GetExchangeUser method which returns an ExchangeUser object that represents the AddressEntry if the AddressEntry belongs to an Exchange AddressList object such as the Global Address List (GAL) and corresponds to an Exchange user. In that case the ExchangeUser.PrimarySmtpAddress 属性 returns 表示 ExchangeUser 的主要简单邮件传输协议 (SMTP) 地址的字符串。

您可能会发现 How To: Fill TO,CC and BCC fields in Outlook programmatically 文章很有帮助。

Answer 2

这演示了如何应用其中一个可能的答案 How do you extract email addresses from the 'To' field in outlook?.

Option Explicit

Sub FetchEmailData_Call_smtpAddress()

Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object

Dim iRow As Long

' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.getnamespace("MAPI")

Set olFolder = olNs.PickFolder

If olFolder Is Nothing Then
    Debug.Print "User cancelled."
    Exit Sub
End If

' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
    
' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")

For iRow = 1 To olFolder.items.Count
        
    Set olItem = olFolder.items.Item(iRow)
        
    With olItem
        
        Cells(iRow + 1, 1) = .Sender
        Cells(iRow + 1, 2) = .To
        Cells(iRow + 1, 3) = .CC
        Cells(iRow + 1, 4) = .receivedtime
            
        If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
            Cells(iRow + 1, 5) = .Sender.GetExchangeUser().PrimarySmtpAddress
        Else
            On Error Resume Next
            Cells(iRow + 1, 5) = .SenderEmailAddress
            On Error GoTo 0 ' consider mandatory
        End If
            
        ' Pass the item to smtpAddress
        smtpAddress olItem
        ' You could move the smtpAddress code into the main sub.
        ' Entering the email addresses in the next empty cells in the row, should be easier.
        
    End With
        
Next iRow
    
ThisWorkbook.ActiveSheet.Columns.AutoFit

Debug.Print "Done."

End Sub


Private Sub smtpAddress(ByVal Item As Object)

    ' 

    Dim addrRecips As Object    ' Outlook.Recipients
    Dim addrRecip As Object     ' Outlook.Recipient
    Dim pa As Object            ' Outlook.propertyAccessor

    ' This URL cannot be clicked nor pasted into a browser.
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set addrRecips = Item.Recipients

    For Each addrRecip In addrRecips
        Set pa = addrRecip.PropertyAccessor
        Debug.Print pa.GetProperty(PR_SMTP_ADDRESS)
    Next

End Sub

通过 VBA 在 Excel 中获取收件人和抄送列表中的电子邮件

Getting emails of recipients, and those in the CC list through VBA in Excel

email

excel

outlook

vba

office-automation