在Excel中通过VBA获取收件人的邮箱地址和抄送列表中的邮箱地址

Question

我在网上复制了一些代码，可以从每封邮件中提取某些细节。

是否可以将代码修改为包含收件人和抄送列表中的邮件地址?

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

这演示了如何将其中一个可能的答案应用于如何在outlook中从"To"字段中提取电子邮件地址?

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)
' https://stackoverflow.com/a/12642193/1571407
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

Answer 2

您可以使用Recipients属性获取Outlook中特定邮件的所有收件人。收件人。Type属性返回或设置表示收件人类型的长字符串。对于邮件项，值显示在OlMailRecipientType枚举中:

• olBCC- 3 -收件人在项目的BCC属性中指定。
• olCC- 2 -收件人在项目的CC属性中指定。
• olOriginator- 0 -Originator(发送方)。
• olTo- 1 -收件人在项目的To属性中指定。

因此，您可以找到一个与CC字段对应的收件人对象并使用收件人。AddressEntry属性，返回解析后的收件人对应的AddressEntry对象。

Set myAddressEntry = myRecipient.AddressEntry 

AddressEntry。Address属性返回或设置一个字符串，表示AddressEntry的电子邮件地址。在Exchange账户的情况下，您可以使用地址栏。GetExchangeUser方法，如果AddressEntry属于ExchangeAddressList对象(如全局地址列表(GAL))并对应于Exchange用户，则返回一个代表AddressEntry的ExchangeUser对象。在这种情况下，是ExchangeUser。PrimarySmtpAddress属性返回一个字符串，表示ExchangeUser的主SMTP地址。

您可能会发现如何:在Outlook中以编程方式填写收件人，抄送和密件抄送字段的文章很有帮助。