问通过Excel中的VBA获取收件人和CC列表中收件人的电子邮件地址

EN

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