将电子邮件详细信息从 Outlook 导出到 Excel
Export email details from Outlook to Excel
我有一个代码（我从 How do you extract email addresses from the 'To' field in outlook? 和另一个消失的源中复制并稍微编辑了它）目前正在用于提取日期、姓名和电子邮件地址（发件人、收件人、抄送）特定邮件文件夹中的每封电子邮件。然而，在 cross-referencing 使用从 Outlook 手动导出的电子邮件列表（通过导入和导出向导）后，我意识到大约有 30 封电子邮件在 VBA 导出的 table 中有错误.对于包含各自电子邮件信息的每一行，“发件人”、“收件人”和“抄送”中的名称均为空白，而相应的电子邮件列只是成功提取的前一封电子邮件的副本。到目前为止，根据我的观察，这些电子邮件之间的相似之处在于它们都是针对 Microsoft 团队会议的（例如，邀请参加团队会议）。下图描述了错误：
此外，一个人有两个电子邮件地址（每个地址都有不同的域）。但是，只有一个邮箱地址成功导出了对应的邮箱；包含其他电子邮件地址的电子邮件无法导出该特定电子邮件地址，即使他们的名字仍然存在。同样，错误是这样的：
请帮助我识别并在可能的情况下纠正上述问题，因为我几乎没有编码经验。提前致谢。代码如下-
Option Explicit
Sub GetEmail()
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:G1") = Array("From:", "To:", "CC:", "SenderEmailAddress", "RecipientEmailAddress", "CCEmailAddress", "Date")
For iRow = 1 To olFolder.Items.Count
Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).Sender
On Error Resume Next
Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).To
Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).CC
Dim Arr As Variant: Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = olFolder.Items.Item(iRow).ReceivedTime
Next iRow
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
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
End Select
End With
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(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
错误处理可能很乏味，这就是为什么经常看到毯子 On Error Resume Next 的原因。这会隐藏错误，因此结果不可信。对于没有经验的人来说，“代码运行”是莫名其妙的。
可以说 On Error GoTo ExitFunction 更好，因为它没有给出任何结果，因此您会意识到存在问题。
删除 On Error Resume Next 和 On Error GoTo ExitFunction 后，您可以在看到需要错误处理的地方后构建自己的错误处理逻辑。
根据需要进行调整。
Option Explicit
Sub GetEmail()
Dim appOutlook As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Long
Dim Arr As Variant
' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0 ' <-- Remove error bypass as soon as possible
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
Set olFolder = Session.PickFolder
If olFolder Is Nothing Then Exit Sub
' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
' Build headings:
Range("A1:G1") = Array("From:", "To:", "CC:", "SenderEmailAddress", "RecipientEmailAddress", "CCEmailAddress", "Date")
For iRow = 1 To olFolder.Items.Count
Set olItem = olFolder.Items.Item(iRow)
If olItem.Class = olMail Then
With olItem
Cells(iRow + 1, 1) = .Sender
Cells(iRow + 1, 2) = .To
Cells(iRow + 1, 3) = .CC
Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = .ReceivedTime
End With
Else
Cells(iRow + 1, 8) = "Errors, due to object not having mailtem property, bypassed."
With olItem
On Error Resume Next
Cells(iRow + 1, 1) = .Sender
Cells(iRow + 1, 2) = .To
Cells(iRow + 1, 3) = .CC
On Error GoTo 0 ' <-- Remove error bypass as soon as possible
Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = .ReceivedTime
End With
End If
Next iRow
End Sub
Private Function EmailAddressInfo(objItem As Object) As Variant
'
Dim olRecipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim olEDL As Outlook.ExchangeDistributionList
Dim ToAddress As String
Dim CCAddress As String
Dim Originator As String
Dim email As String
If objItem.Class <> olMail Then
EmailAddressInfo = Array("Not a mailitem.", "", "")
Exit Function
End If
Debug.Print objItem.Subject
With objItem
Select Case UCase(.SenderEmailType)
Case "SMTP"
If Len(.SenderEmailAddress) > 0 Then
Originator = .SenderEmailAddress
Else
Originator = "Not available."
End If
Debug.Print "Originator: " & Originator
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then
Originator = olEU.PrimarySmtpAddress
Debug.Print "Originator: " & Originator
End If
End Select
End With
For Each olRecipient In objItem.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
If Not olEU Is Nothing Then
' This may be valid somewhere but
' in my environment it is never used
email = olEU.PrimarySmtpAddress
Debug.Print " olEU.PrimarySmtpAddress: " & email
Else
Debug.Print
Debug.Print "**** olEU Is Nothing ****"
'
' "It looks like, for email addresses outside of your organization,
' the SMTP address is hidden in emailObject.Recipients(i).Address"
email = .Address
Debug.Print " olRecipient.Address: " & email
End If
End Select
If email <> "" Then
Select Case .Type
Case olTo
ToAddress = ToAddress & email & ";"
Debug.Print ToAddress
Case olCC
CCAddress = CCAddress & email & ";"
Debug.Print CCAddress
End Select
End If
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
End Function
我有一个代码（我从 How do you extract email addresses from the 'To' field in outlook? 和另一个消失的源中复制并稍微编辑了它）目前正在用于提取日期、姓名和电子邮件地址（发件人、收件人、抄送）特定邮件文件夹中的每封电子邮件。然而，在 cross-referencing 使用从 Outlook 手动导出的电子邮件列表（通过导入和导出向导）后，我意识到大约有 30 封电子邮件在 VBA 导出的 table 中有错误.对于包含各自电子邮件信息的每一行，“发件人”、“收件人”和“抄送”中的名称均为空白，而相应的电子邮件列只是成功提取的前一封电子邮件的副本。到目前为止，根据我的观察，这些电子邮件之间的相似之处在于它们都是针对 Microsoft 团队会议的（例如，邀请参加团队会议）。下图描述了错误：
此外，一个人有两个电子邮件地址（每个地址都有不同的域）。但是，只有一个邮箱地址成功导出了对应的邮箱；包含其他电子邮件地址的电子邮件无法导出该特定电子邮件地址，即使他们的名字仍然存在。同样，错误是这样的：
请帮助我识别并在可能的情况下纠正上述问题，因为我几乎没有编码经验。提前致谢。代码如下-
Option Explicit
Sub GetEmail()
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:G1") = Array("From:", "To:", "CC:", "SenderEmailAddress", "RecipientEmailAddress", "CCEmailAddress", "Date")
For iRow = 1 To olFolder.Items.Count
Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).Sender
On Error Resume Next
Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).To
Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).CC
Dim Arr As Variant: Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = olFolder.Items.Item(iRow).ReceivedTime
Next iRow
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
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
End Select
End With
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(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
错误处理可能很乏味，这就是为什么经常看到毯子 On Error Resume Next 的原因。这会隐藏错误，因此结果不可信。对于没有经验的人来说，“代码运行”是莫名其妙的。
可以说 On Error GoTo ExitFunction 更好，因为它没有给出任何结果，因此您会意识到存在问题。
删除 On Error Resume Next 和 On Error GoTo ExitFunction 后，您可以在看到需要错误处理的地方后构建自己的错误处理逻辑。
根据需要进行调整。
Option Explicit
Sub GetEmail()
Dim appOutlook As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Long
Dim Arr As Variant
' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0 ' <-- Remove error bypass as soon as possible
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
Set olFolder = Session.PickFolder
If olFolder Is Nothing Then Exit Sub
' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
' Build headings:
Range("A1:G1") = Array("From:", "To:", "CC:", "SenderEmailAddress", "RecipientEmailAddress", "CCEmailAddress", "Date")
For iRow = 1 To olFolder.Items.Count
Set olItem = olFolder.Items.Item(iRow)
If olItem.Class = olMail Then
With olItem
Cells(iRow + 1, 1) = .Sender
Cells(iRow + 1, 2) = .To
Cells(iRow + 1, 3) = .CC
Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = .ReceivedTime
End With
Else
Cells(iRow + 1, 8) = "Errors, due to object not having mailtem property, bypassed."
With olItem
On Error Resume Next
Cells(iRow + 1, 1) = .Sender
Cells(iRow + 1, 2) = .To
Cells(iRow + 1, 3) = .CC
On Error GoTo 0 ' <-- Remove error bypass as soon as possible
Arr = EmailAddressInfo(olFolder.Items(iRow))
Cells(iRow + 1, 4) = Arr(olOriginator)
Cells(iRow + 1, 5) = Arr(olTo)
Cells(iRow + 1, 6) = Arr(olCC)
Cells(iRow + 1, 7) = .ReceivedTime
End With
End If
Next iRow
End Sub
Private Function EmailAddressInfo(objItem As Object) As Variant
'
Dim olRecipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim olEDL As Outlook.ExchangeDistributionList
Dim ToAddress As String
Dim CCAddress As String
Dim Originator As String
Dim email As String
If objItem.Class <> olMail Then
EmailAddressInfo = Array("Not a mailitem.", "", "")
Exit Function
End If
Debug.Print objItem.Subject
With objItem
Select Case UCase(.SenderEmailType)
Case "SMTP"
If Len(.SenderEmailAddress) > 0 Then
Originator = .SenderEmailAddress
Else
Originator = "Not available."
End If
Debug.Print "Originator: " & Originator
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then
Originator = olEU.PrimarySmtpAddress
Debug.Print "Originator: " & Originator
End If
End Select
End With
For Each olRecipient In objItem.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
If Not olEU Is Nothing Then
' This may be valid somewhere but
' in my environment it is never used
email = olEU.PrimarySmtpAddress
Debug.Print " olEU.PrimarySmtpAddress: " & email
Else
Debug.Print
Debug.Print "**** olEU Is Nothing ****"
'
' "It looks like, for email addresses outside of your organization,
' the SMTP address is hidden in emailObject.Recipients(i).Address"
email = .Address
Debug.Print " olRecipient.Address: " & email
End If
End Select
If email <> "" Then
Select Case .Type
Case olTo
ToAddress = ToAddress & email & ";"
Debug.Print ToAddress
Case olCC
CCAddress = CCAddress & email & ";"
Debug.Print CCAddress
End Select
End If
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
End Function