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.
First step is enabling macros in Outlook. On most recent versions the path is something like this:
Fire up the VBA editor by pressing ALT-F11, and expand the existing Project file (on the left) like this:
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, "") Next 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) Next 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 Next i = i + 1 End If Next End Sub
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.
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