Get email address of all users from all mails in Outlook Folder

Sometimes you want to send some important notice to everyone who
has ever mailed you. Let’s say you have a folder named “Friends” in
Outlook where you store all the emails from your friends. Now you
want to get all of their email addresses. Pretty difficult work if
you have thousands of such mails. Here’s an easy way.

  • Select the folder in Outlook and press ALT+F11. It will open
    Visual Basic Editor.
  • Double click on ThisOutlookSession from the Project tree.
  • Paste the following function:

Sub GetALLEmailAddresses()

Dim objFolder As Folder
Set objFolder = Application.ActiveExplorer.Selection

Dim dic As New Dictionary
Dim strEmail As String
Dim strEmails As String

Dim objItem As MailItem
For Each objItem In objFolder.Items

strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + “;”
dic.Add strEmail, “”
End If

Next

Debug.Print strEmails
End Sub

Hit F5 and it will run for a while. Then press Ctrl+G. You will
see the email addresses in the “Immediate
Window”.

Copy the whole string and you have all the email addresses from
all the emails in the selected Outlook folder. There will be no
duplicate address in the list.

36 thoughts on “Get email address of all users from all mails in Outlook Folder”

  1. More better…

    Sub GetALLEmailAddresses()

    Dim objFolder As MAPIFolder

    Dim strEmail As String

    Dim strEmails As String

    ”’ Requires reference to Microsoft Scripting Runtime

    Dim dic As New Dictionary

    Dim objItem As Object

    ”Set objFolder = Application.ActiveExplorer.Selection

    Set objFolder = Application.GetNamespace(“Mapi”).PickFolder

    For Each objItem In objFolder.Items

    If objItem.Class = olMail Then

    strEmail = objItem.SenderEmailAddress

    If Not dic.Exists(strEmail) Then

    strEmails = strEmails + strEmail + “;”

    dic.Add strEmail, “”

    End If

    End If

    Next

    Debug.Print strEmails

    End Sub

  2. Hey what do I need installed for the script to run? I’m getting a ‘user-defined type not defined’ compile error on the Folder type. I have the Office 2003 Resource Kit and .NET Programmability Support / VB Scripting Support features installed for Outlook.

  3. First of all, I like your blogs.

    Secondly, The code you gave did not work for me, So I chnaged the code a little to make it work.

    Here is the updated code.

    Sub GetALLEmailAddresses()

       Dim objExplorer As Explorer

       Set objExplorer = Application.ActiveExplorer()

       

       Dim objFolder As MAPIFolder

       Set objFolder = objExplorer.CurrentFolder

       

       Dim dic As New Dictionary

       Dim strEmail As String

       Dim strEmails As String

       Dim objItem As MailItem

       

       For Each objItem In objFolder.Items

           strEmail = objItem.SenderEmailAddress

           

           If Not dic.Exists(strEmail) Then

               strEmails = strEmails + strEmail + “;”

               dic.Add strEmail, “”

           End If

       Next

       

       Debug.Print strEmails

    End Sub

  4. Hi, try this code instead (simple version, without the dictionary object)

    Sub GetALLEmailAddresses()

    Dim objFolder As MAPIFolder

    Dim strEmail As String

    Dim strEmails As String

    Dim objItem As Object

    ''Set objFolder = Application.ActiveExplorer.Selection

    Set objFolder = Application.GetNamespace(“Mapi”).PickFolder

    For Each objItem In objFolder.Items

    If objItem.Class = olMail Then

    strEmail = objItem.SenderEmailAddress

    If InStr(strEmails, strEmail) = 0 Then strEmails = strEmails + strEmail + “;”

    End If

    Next

    Debug.Print strEmails

    End Sub

  5. hey the last script from Jacob worked for me great-

    how would I change this to grab the CC: addresses as well as the sender addresses??

  6. How do I change the script to get all the email addresses for the recepients of all the emails I have sent?

  7. This code is so close to exactly what I needed and I thank you guys a lot for putting it together.

    However I was wondering if someone could write a few lines into it that would let you select the top folder, and have it recurse down through ever folder nested under that.

  8. Okay guys, I worked on this for a little while and it finnaly works, abate messyness. I found a module to print this to a text file and two moduels for the recursive function: one takes names, e-mail, and subject from each e-mail and makes a list that is pastable into excel. The other makes a list of every e-mail with no duplicates. Choose the one you want call.

    'This is the main Sub, It picks the folder and calls the functions to recurse and save

    Sub GetALLEmailAddresses()

    Dim objFolder1 As MAPIFolder

    Dim strEmail1 As String

    Dim strEmails1 As String

    Dim objItem As Object

    Dim writeText As Boolean

    Set objFolder1 = Application.GetNamespace(“Mapi”).PickFolder

    strEmails1 = GetMessages(objFolder1, True)

    'strEmails1 = GetMessageEmails(objFolder1, True)

    Debug.Print strEmails1

    writeText = SaveTextToFile(“C:file.txt”, strEmails1, True)

    End Sub

    'this is verbatem from http://www.freevbcode.com/ShowCode.Asp, it saves the files to a text file

    Public Function SaveTextToFile(FileFullPath As String, _

    sText As String, Optional Overwrite As Boolean = False) As _

    Boolean

    'Purpose: Save Text to a file

    'Parameters:

    '– FileFullPath – Directory/FileName to save file to

    '– sText – Text to write to file

    '– Overwrite (optional): If true, if the file exists, it

    'is overwritten. If false,

    'contents are appended to file

    'if the file exists

    'Returns: True if successful, false otherwise

    'Example:

    'SaveTextToFile “C:My DocumentsMyFile.txt”, “Hello There”

    On Error GoTo ErrorHandler

    Dim iFileNumber As Integer

    iFileNumber = FreeFile

    If Overwrite Then

    Open FileFullPath For Output As #iFileNumber

    Else

    Open FileFullPath For Append As #iFileNumber

    End If

    Print #iFileNumber, sText

    SaveTextToFile = True

    ErrorHandler:

    Close #iFileNumber

    End Function

    'This is the GetMessages that takes a folder and returns a list of the “name, e=mail, subject”s

    Public Function GetMessages(oFolder As MAPIFolder, ByVal bRecursive As Boolean) As String

    Dim objFolder As Outlook.MAPIFolder

    Dim strEmail As String

    Dim strEmails As String

    Dim strName As String

    Dim strSubject As String

    Dim strAll As String

    Dim strItemAll As String

    Dim objItem As Object

    Dim objFolders As Outlook.Folders

    Set objFolders = oFolder.Folders

    For Each objFolder In objFolders

    For Each objItem In objFolder.Items

    If objItem.Class = olMail Then

    strEmail = objItem.SenderEmailAddress

    strName = objItem.SenderName

    strSubject = objItem.Subject

    strItemAll = strName + “,” + strEmail + “,” + strSubject

    'If InStr(strEmails, strEmail) = 0 Then strEmails = strEmails + strEmail + “;”

    strAll = strAll & Chr(13) & strItemAll

    End If

    Next

    If bRecursive Then

    ' Might want to compare this to strEmails instead of just appending.

    strAll = strAll + GetMessages(objFolder, bRecursive)

    End If

    Next

    GetMessages = strAll

    End Function

    'This is the the function that returns a list of “;” delimited e-mails with no duplicates.

    Public Function getMessageEmails(oFolder As MAPIFolder, ByVal bRecursive As Boolean) As String

    Dim objFolder As Outlook.MAPIFolder

    Dim strEmail As String

    Dim strEmails As String

    Dim objItem As Object

    Dim objFolders As Outlook.Folders

    Set objFolders = oFolder.Folders

    For Each objFolder In objFolders

    For Each objItem In objFolder.Items

    If objItem.Class = olMail Then

    strEmail = objItem.SenderEmailAddress

    If InStr(strEmails, strEmail) = 0 Then strEmails = strEmails + strEmail + “;”

    End If

    Next

    If bRecursive Then

    ' Might want to compare this to strEmails instead of just appending.

    strEmails = strEmails + getMessageEmails(objFolder, bRecursive)

    End If

    Next

    getMessageEmails = strEmails

    End Function

  9. Please help, it won't work for me. I have outlook 03 and have tried every code to no avail

  10. Jakob's simple version worked perfectly for me in outlook 2007. all other versions with the dictionary object displayed an error. Now to try to get 400 emails into csv format…

    THANKS!

  11. Really helpful to get email ids from my outlook out of hundreds of emails that I receive everyday.

    Thanks

  12. Hello guys, can you modify Jakobs version for me so I can get all email addresses within the email bodies instead of the the “From” field in a selected folder?

    I have saved all bounced back emails in a separate folder and want to get now the email addresses that bounced back to clean the OK list.

  13. Omar al Zabir… Salaam and Thank you very much. You’re the man, and then all those that have added tweaks… errr.. you’re the people.

    I’ve been wanting this kind of feature for ages and I have been building a folder called “make email list” hoping that one day I will find an easy way to do it… and you’ve shown me. I’m using Outlook 2010 so I hope it works. I will try in a few days.

    Then I can notify all my contacts about my new website!

    All i need now, is work out how to not get caught up in the SPAM mess if I’m going to be sending the email to the 100’s or maybe 000s of email addresses I expect to have on the list! That obviously wont help my rankings!

  14. Hi all…

    Omar tx for the Idea… I took your code and rewrite it a bit so it extract email from subfolders to

    NOTE: Guys if you copy paste the code you have to change the quetes because of the wrong font and you have to add reference to Microsoft Scripting Runtime: Tools –> References –> check “Microsoft Scripting Runtime”

    regards

    Sub EmailExport()
    ‘Requires reference to Microsoft Scripting Runtime
    ‘Tools –> References –> check “Microsoft Scripting Runtime”

    Dim outApp As New Outlook.Application
    Dim mpf As Outlook.MAPIFolder
    Dim mpfSubFolder As Outlook.MAPIFolder
    Dim mpfSubFolder1 As Outlook.MAPIFolder
    Dim flds As Outlook.Folders
    Dim flds1 As Outlook.Folders
    Dim idx As Integer
    Dim strEmail As String
    Dim strEmails As String
    Dim strCC As String
    Dim strCCs As String
    Dim dic As New Dictionary
    Dim i As Integer

    i = 1

    Set mpf = Application.GetNamespace(“Mapi”).PickFolder

    Set flds = mpf.Folders
    Set mpfSubFolder = flds.GetFirst
    Do While Not mpfSubFolder Is Nothing
    Debug.Print i & “-” & mpfSubFolder
    For Each objItem In mpfSubFolder.Items
    If objItem.Class = olMail Then
    strEmail = objItem.SenderEmailAddress
    strCC = objItem.cc
    If Not dic.Exists(strEmail) Then
    strEmails = strEmails + strEmail + vbCrLf
    strCCs = strCCs + strCC + vbCrLf
    End If
    End If
    Next
    Set flds1 = mpfSubFolder.Folders
    Set mpfSubFolder1 = flds1.GetFirst
    Do While Not mpfSubFolder1 Is Nothing
    Debug.Print i & “-” & mpfSubFolder1
    For Each objItem1 In mpfSubFolder1.Items
    If objItem1.Class = olMail Then
    strEmail = objItem1.SenderEmailAddress
    strCC = objItem1.cc
    If Not dic.Exists(strEmail) Then
    strEmails = strEmails + strEmail + vbCrLf
    strCCs = strCCs + strCC + “;”
    End If
    End If
    Next
    Set mpfSubFolder1 = flds1.GetNext
    i = i + 1
    Loop
    Set mpfSubFolder = flds.GetNext
    i = i + 1
    Loop
    writeText = SaveTextToFile(“C:file.txt”, strEmails, True)
    writeText = SaveTextToFile(“C:fileCC.txt”, strCCs, True)
    dic.Add strEmail, “”
    End Sub

    ‘this is verbatem from http://www.freevbcode.com/ShowCode.Asp, it saves the files to a text file

    Public Function SaveTextToFile(FileFullPath As String, sText As String, Optional Overwrite As Boolean = False) As Boolean

    ‘Purpose: Save Text to a file

    ‘Parameters:

    ‘– FileFullPath – Directory/FileName to save file to

    ‘– sText – Text to write to file

    ‘– Overwrite (optional): If true, if the file exists, it

    ‘is overwritten. If false,

    ‘contents are appended to file

    ‘if the file exists

    ‘Returns: True if successful, false otherwise

    ‘Example:

    ‘SaveTextToFile “C:My DocumentsMyFile.txt”, “Hello There”

    On Error GoTo ErrorHandler

    Dim iFileNumber As Integer

    iFileNumber = FreeFile

    If Overwrite Then
    Open FileFullPath For Output As #iFileNumber
    Else
    Open FileFullPath For Append As #iFileNumber
    End If

    Print #iFileNumber, sText

    SaveTextToFile = True

    ErrorHandler:

    Close #iFileNumber

    End Function

  15. AAARGH… Outlook 2007.

    I keep getting “One or more parameter values are not valid”. I am currently trying to use Bujez’s code. I have copied and pasted exactly, enabled Microsoft Scripting Runtime and changed the quote marks (“).

    What do I do? I have tried previously Omars code and the others.

  16. ok, sorry guys… i missed the odd quaotation marks (“) that had to be changed. It works. Thanks! Brilliant. Now if only it can go through the body of emails too… cant please some people eh?!

  17. Ha! Finally got it working with the simple, unfortunately i cant see by whom the post was made.

    And i’m just an end-user so you can imagine the hours you guys saved.

    Thanks!!!!!!!

  18. When I ran the simple (without Dic) version, it gave me a run time error that says –

    Run-time Error ‘-2147024809 (80070057)
    Could not complete the operation. One or more parameter values are not valid.

    Can somebody please help.

    1. Ashish and others — this runtime error is likely due to the way you might copy/paste from a web browser into the VB editor. The VB editor accepts the special characters like slanted double-quotes and single-quotes, so they are not valid.

      You need to go to all double-quotes and single-quotes in the code and replace them with proper double and single quotes.

  19. Hello,

    I am using Microsoft Outlook 2007, I have tried to copy paste all options suggested above but none is worked for me as it show always error message while giving F5, can any one help me to run it successfully.

    It would be great help,

    My email id is educationworld@gmail.com

    Also guide me how to follow this blog as I did try to check where I can register my email id but could not find any details.

    Prasanna Acharya

  20. Hello Guys,

    I am using outlook 2010 professional 64bit, can anybody help me out to get the email ids from my outlook, I have more than 1lakh email in my inbox. So, it would be really helpful for me if you provide me the solution.

    Thank you,

    Regards,
    Vijay

  21. I ran the script below on a folder that contains 2000 emails. I’m doing this on outlook 2007.

    But it only retrieved about 40 addresses. Now each of the 2000 emails goes to a different person, no duplicates.

    any thought why if only grabs 40 addresses?

    Thanks

    Sub GetALLEmailAddresses()

    Dim objFolder As MAPIFolder
    Dim strEmail As String
    Dim strEmails As String
    ”’ Requires reference to Microsoft Scripting Runtime
    Dim dic As New Dictionary
    Dim objItem As Object

    ”Set objFolder = Application.ActiveExplorer.Selection
    Set objFolder = Application.GetNamespace(“Mapi”).PickFolder

    For Each objItem In objFolder.Items

    If objItem.Class = olMail Then

    strEmail = objItem.SenderEmailAddress

    If Not dic.Exists(strEmail) Then

    strEmails = strEmails + strEmail + vbCrLf

    dic.Add strEmail, “”

    End If

    End If

    Next

    Debug.Print strEmails

    End Sub

  22. I tried all te posibilities but it doesn’t work in Outlook 2007.

    got a syntax fault:

    If InStr(strEmails, strEmail) = 0 Then strEmails = strEmails + strEmail + “;”

Leave a Reply