A Script To Export From Outlook The Email Address Of Everyone Who Has Ever Emailed You
I was asked a few days ago if I could write something to get the email addresses of the senders of all the received messages in a colleague’s mailbox. He wanted to build a contact list of everyone who’d ever sent him an email (not including permanently deleted messages, of course). To make things more interesting, he wanted to include all the .PST files (Personal Folders stores) he also had mounted, because that’s where most of his emails actually resided.
Anyway, it’s not too difficult. Here’s a little script that will put them all into a text file (display names and email addresses, separated by a comma so that they can be imported as a .csv file). It’s called from a batch file so that you can see the message subjects scroll up in a console window (so that you can tell it’s still doing something). Beware, though, for a big mailbox, it could take maybe an hour to finish. You end up with a file named ContactList.txt.
First (because it’s simpler) here is the batch file. Call it Contacts.bat. This is what you double-click when you want to run the thing.
cscript contacts.vbs pause
And here is the file that does the actual work. Call it Contacts.vbs . Note the line that includes the text YOURDOMAIN.COM. Put your own domain in there, so that it will ignore internal emails.
Dim arrContacts(10000) Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.CreateTextFile("ContactList.txt", True, True) Set objStdOut = fso.GetStandardStream(1) ' 1 indicates stdOut Set objOutlook = CreateObject("Outlook.Application") Set objNamespace = objOutlook.GetNamespace("MAPI") Set objStore = objNamespace.DefaultStore n = 0 For Each objStore In objNameSpace.Session.Stores If objStore.DisplayName <> "Public Folders" Then For Each objFolder In objStore.GetRootFolder.Folders doFolder objFolder Next End If Next Sub doFolder(inObjFolder) For Each objItem In inObjFolder.Items If objItem.Class = 43 Then ' Ignore Contacts, Appointments, Tasks, etc. strSubject = objItem.Subject On Error Resume Next objStdout.WriteLine strSubject On Error Goto 0 On Error Resume Next strName = objItem.SenderName If Err = 0 Then blnFound = False For i = 1 To n If strName = arrContacts(i) Then blnFound = True Next If Not blnFound Then n = n + 1 arrContacts(n) = strName strAddress = GetReplyToAddress(objItem) If strAddress <> "" Then ' Ignore senders from your own domain If Instr(UCase(strAddress), "YOURDOMAIN.COM") = 0 Then f.WriteLine strName & "," & strAddress End If End If End If On Error Goto 0 End If Next For Each objSubFolder in inObjFolder.Folders doFolder objSubFolder Next End Sub Function GetReplyToAddress(objMsg) strAddress = "" On Error Resume Next Set objReply = objMsg.Reply If Err = 0 Then Set objRecip = objReply.Recipients.Item(1) If Err = 0 Then strAddress = objRecip.Address If strAddress = "" Then strAddress = objRecip.Name End If End If Set objRecip = Nothing Set objReply = Nothing End If On Error Goto 0 GetReplyToAddress = strAddress End Function