Export email details from Outlook to Excel-CodePudding

I have a code (which I copied and edited it slightly from

Furthermore, one individual had two email addresses (each with different domains). However, only one of the email address was successfully exported out for its corresponding email; the emails which contained the other email address failed to export that particular email address, even though their name was still there. Similarly, the error was like this:

Kindly help me to identify and if possible, rectify the above problems as I have little to no experience in coding. Thanks in advance. The code is as follows -

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

CodePudding user response：

Error handling can be tedious which is why the blanket On Error Resume Next is often seen. This hides errors so results are not trustworthy. It is baffling to the inexperienced as "the code runs".

Arguably On Error GoTo ExitFunction is better as it gives no results so you are made aware there is a problem.

With both On Error Resume Next and On Error GoTo ExitFunction removed you can build your own error handling logic once you see where error handling is required.

Adjust as you see fit.

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