A Script To Export From Outlook The Email Address Of Everyone Who Has Ever Emailed You

[ 4 ] Comments

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

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
  End If

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
        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
  For Each objSubFolder in inObjFolder.Folders
    doFolder objSubFolder
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

4 Responses to A Script To Export From Outlook The Email Address Of Everyone Who Has Ever Emailed You

  1. Morten says:

    I want the opposite way. Find all I have Sent to excluding internal users. How can I accomplish that?

  2. I want to extract the sent folder email address , with the date time .
    Can it be possible , if yes please provide me the code thanks .

Leave a Reply

Your email address will not be published.

You may use these HTML tags and attributes: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>