I need to extract all email addresses from my sent and received emails in Outlook and export them into a CSV file. However, I don’t just want my saved contacts—I need every unique email address I've interacted with. What I’ve Tried: Exporting via Outlook's built-in Import/Export tool, but it only gives me standard email fields, not every address from my email history. Using VBA macros, but I have trouble opening the VBA Editor (ALT + F11 doesn’t work on my LATAM keyboard). Looking into Power Automate, but I’m unsure how to set up the flow correctly. Requirements: Extract all email addresses from Inbox and Sent Items. Export them into a CSV file. A solution that works without full admin access. Is there a VBA script, Power Automate flow, or another method I can use to achieve this? Also, how can I open the VBA Editor on a LATAM keyboard if ALT + F11 doesn’t work? Any guidance would be greatly appreciated!

I need to extract all email addresses from my sent and received emails in Outlook and export them into a CSV file. However, I don’t just want my saved contacts—I need every unique email address I've interacted with. What I’ve Tried: Exporting via Outlook's built-in Import/Export tool, but it only gives me standard email fields, not every address from my email history. Using VBA macros, but I have trouble opening the VBA Editor (ALT + F11 doesn’t work on my LATAM keyboard). Looking into Power Automate, but I’m unsure how to set up the flow correctly. Requirements: Extract all email addresses from Inbox and Sent Items. Export them into a CSV file. A solution that works without full admin access. Is there a VBA script, Power Automate flow, or another method I can use to achieve this? Also, how can I open the VBA Editor on a LATAM keyboard if ALT + F11 doesn’t work? Any guidance would be greatly appreciated!

• excel
• vba
• email
• outlook

• File > Options > Customize Ribbon > Developer to add the developer tab / open the VBE. – BigBen Commented Mar 18 at 20:41
• Please provide enough code so others can better understand or reproduce the problem. – Community Bot Commented Mar 18 at 21:23

1 Answer 1

This VBA script extracts unique email addresses from both the Inbox and Sent Items folders in Outlook. It uses a regular expression to validate email addresses, ensuring only valid ones are included. The script handles different types of email addresses, including Exchange addresses, by converting them to their SMTP format. Finally, it writes the validated email addresses to a CSV file for easy export.

It's a quick adaptation of old code, I have tested it on my computer and it seems to work.

Sub ExtractEmailAddresses()
    Dim objOutlook As Object
    Dim objNamespace As Object
    Dim objFolder As Object
    Dim objItem As Object
    Dim objMail As Object
    Dim colUniqueEmails As Object
    Dim strEmail As Variant
    Dim i As Long
    Dim objFSO As Object
    Dim objFile As Object
    Dim objRecipient As Object
    Dim objRecipients As Object

    ' Create Outlook application object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set colUniqueEmails = CreateObject("Scripting.Dictionary")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile("C:\test\Emails.csv", True) 'change as required

    ' Process Inbox
    Set objFolder = objNamespace.GetDefaultFolder(6)
    For Each objItem In objFolder.Items
        If objItem.Class = 43 Then ' olMail
            Set objMail = objItem
            strEmail = GetSMTPAddress(objMail.Sender)
            If IsValidEmail(CStr(strEmail)) And Not colUniqueEmails.Exists(strEmail) Then
                colUniqueEmails.Add strEmail, Nothing
            End If
        End If
    Next objItem
    
    Set objFolder = objNamespace.GetDefaultFolder(5)
    For Each objItem In objFolder.Items
        If objItem.Class = 43 Then
            Set objMail = objItem
            Set objRecipients = objMail.Recipients
            For Each objRecipient In objRecipients
                strEmail = GetSMTPAddress(objRecipient)
                If IsValidEmail(CStr(strEmail)) And Not colUniqueEmails.Exists(strEmail) Then
                    colUniqueEmails.Add strEmail, Nothing
                End If
            Next objRecipient
        End If
    Next objItem

    ' Write to CSV
    For Each strEmail In colUniqueEmails.Keys
        objFile.WriteLine strEmail
    Next strEmail

    objFile.Close
    MsgBox "Email addresses have been exported"
End Sub

Function GetSMTPAddress(objAddressEntry As Object) As String
    Dim objExchangeUser As Object
    Dim objExchangeDistList As Object

    On Error Resume Next
    ' Check if the address is an Exchange user
    Set objExchangeUser = objAddressEntry.GetExchangeUser
    If Not objExchangeUser Is Nothing Then
        GetSMTPAddress = objExchangeUser.PrimarySmtpAddress
        Exit Function
    End If

    ' Check if the address is an Exchange distribution list
    Set objExchangeDistList = objAddressEntry.GetExchangeDistributionList
    If Not objExchangeDistList Is Nothing Then
        GetSMTPAddress = objExchangeDistList.PrimarySmtpAddress
        Exit Function
    End If

    ' If not an Exchange address, return the address as is
    GetSMTPAddress = objAddressEntry.Address
End Function

Function IsValidEmail(strEmail As String) As Boolean
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "^[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,}$"
    regex.IgnoreCase = True
    IsValidEmail = regex.Test(strEmail)
End Function