我有一個代碼（我從
此外，一個人有兩個電子郵件地址（每個都有不同的域）。但是，只有一個電子郵件地址成功匯出了其對應的電子郵件；包含另一個電子郵件地址的電子郵件無法匯出該特定電子郵件地址，即使他們的名字仍然存在。同樣，錯誤是這樣的：
請幫助我識別并在可能的情況下糾正上述問題，因為我幾乎沒有編碼經驗。提前致謝。代碼如下 -
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
uj5u.com熱心網友回復：
錯誤處理可能很乏味，這就是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
' https://stackoverflow.com/a/66484483/1571407
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 ****"
' https://stackoverflow.com/a/51939384/1571407
' "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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/472951.html