Extract all email addresses from Outlook

My wife is changing her job, and asked my help to extract all email addresses from her Outlook so that she could send a goodbye email to all her contacts. Outlook has this feature of exporting some fields to CSV but it has some major problems:

  • It does not allow you to export multiple folders, let alone multiple Personal Folders
  • It does not preserve unicode characters
  • It does not remove duplicates

For solving this problem, I wrote a VBA macro to extract all your contacts from all your mail folders. The Macro is easy to use, and you can customize to your needs.

  1. First step is enabling macros in Outlook. On most recent versions the path is something like this:

  2. Fire up the VBA editor by pressing ALT-F11, and expand the existing Project file (on the left) like this:

  3. Paste the following VBA code

    Option Explicit
    Public dict As Variant
    Dim myPath As String, nameEmail As String, strFilename As String
    Dim intLogFile, include As Integer
    Dim pst As Variant, subfolder As Variant, csvFile As Object  
    Sub ExtractEmailAddresses()
        Set dict = CreateObject("Scripting.Dictionary")
        'Set CurFolder = Application.ActiveExplorer.CurrentFolder
        Dim myNameSpace As NameSpace
        Set myNameSpace = Application.GetNamespace("MAPI")
        Dim fileName As String
        fileName = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp")) & "\emails.csv"
        If Dir$(fileName) <> "" Then Kill (fileName) '  delete if exists
        Set csvFile = CreateObject("ADODB.Stream")
        csvFile.Type = 2 'Specify stream type - we want To save text/string data.
        csvFile.Charset = "utf-8" 'Specify charset For the source text data.
        csvFile.Open 'Open the stream And write binary data To the object
        On Error Resume Next
        For Each pst In myNameSpace.Folders
            include = MsgBox("Include PST " + pst.Name + " (" + pst.Store.FilePath + ") ?", vbYesNo, "Include PST?")
            If (include = vbYes) Then Call Explorefolder(pst, "")
        csvFile.SaveToFile fileName, 2 'Save binary data To disk
        Shell ("explorer """ & fileName & """")
        Exit Sub
    End Sub
    Sub Explorefolder(ByVal folder As folder, ByVal parentPath As String)
        myPath = parentPath & IIf(Len(parentPath) > 0, "\", "") & folder.Name
        Debug.Print "Reading " & myPath
        Call Listemails(folder)
        For Each subfolder In folder.Folders
            Call Explorefolder(subfolder, myPath)
    End Sub
    Sub Listemails(ByVal folder As folder)
        'Dim msg As MailItem
        Dim msg As Object
        Dim rec As Recipient
        Dim Email As String
        Debug.Print "Items: " & folder.Items.Count
        Dim i As Integer
        i = 1
        For Each msg In folder.Items
            If TypeName(msg) = "MailItem" Then
                'Debug.Print "I: " & i
                For Each rec In msg.Recipients
                    'Debug.Print rec.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E")
                    'Debug.Print rec.name & ": " & rec.Address
                    nameEmail = rec.Name & " <" & rec.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") & ">," ' comma separated names and email addresses
                    'nameEmail = rec.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") & "," ' comma separated email addresses
                    If (IsNull(nameEmail) Or IsEmpty(nameEmail)) Then nameEmail = rec.Address
                    If (IsNull(nameEmail) Or IsEmpty(nameEmail)) Then nameEmail = rec.Name
                    If Not dict.Exists(nameEmail) Then
                        Call dict.Add(nameEmail, nameEmail)
                        csvFile.WriteText nameEmail & vbCrLf
                    End If
                i = i + 1
            End If
    End Sub
  4. Position the cursor inside the ExtractEmailAddresses block, and press F5 to run.

    • It will loop through all your PST (and Exchange OST) folders and ask one by one which ones should be processed
    • Each processed PST/OST will recursively loop throught all folders and subfolders, reading recipients for every message
      You can customize as you want. E.g. you can only see emails YOU sent, or only emails explicitely sent to you, etc.
    • By default, it’s only extracting email address, but if you want you can use the commented line that instead uses the concatenation of both name and email address. Please note that you will probably end up with some duplicated address (same email address and different variations of how the name was written).
    • All distinct values are written to a file “emails.csv” inside your %TEMP% folder.
    • After finishing, this CSV file is opened using default associated program. If doesn’t work you can try replacing CSV by TXT.
    • All addresses are already separated by commas, so that you can just copy and paste into your goodbye email.
  5. Celebrate with your work friends, and enjoy your new job!! :-)

Note: Original code was using “Open file For Append”, but it was incorrectly saving non-ANSI characters, so I changed code to write using UTF-8

comments powered by Disqus