Friday, January 09, 2009

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

Hi,
Ever had the need to extract all email adresses from a folder in Outlook?

Let's say you want to make a reply to a lot of people who are not in your addressbook (contacts), but who have sent you an email which you have archived in a specific folder (or from your Sent items).

I archive my emails all the time using one folder pr. "case", "customer" etc. - and sometimes it's ery useful to be able to write to everyone who had to do with the specific case. This is when it get's a bit frustrating - you have to find a way to get all the email-adresses, and only once!

This is how to do it the easy way:
1. In Outlook press ALT+F11 (opens Microsoft Visual Basic console)
2. Open "ThisOutlookSession" from the Project tree (left menubar)
3. Paste the code below into the project (right window)
4. Press F5 to Run the code (execute)
5. Select the folder you want to use and hit OK (might take some time to complete)
6. Press ALT+G and then copy the email-addresses from the "immediate" window (debug window)

Oh, and remember to use the BCC field if they shouldn't see eachothers email addresses (in the case you want to send an email to all of them).

CODE:
Sub GetEmailAddressesInFolder()
Dim objFolder As MAPIFolder

Dim strEmail As String
Dim strEmails As String
Dim objItem As Object

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


The above code is tested on Microsoft Outlook 2007, but should work on older Office systems too.

Original source here - I just had to modify the code a bit.


Bye for now!
.

6 Comments:

eglzfan said...

This could be just what the doctor ordered for me, but I have two slightly different requirements:

(1) I would love it if I could point to one folder and have it process not only the emails in that folder, but also any subfolders. Can you show me how to tweak the code to do that?

(2) Can the code be tweaked to output to, say, a CSV or text file instead of to the immediate window? Not a huge deal as I can copy and paste, but this would be nice to have as well.

If you would prefer to email me at eglzfan-[AT]-gmail-[DOT]-com, that would also be much appreciated.

Thanks!

Mike Dunham

Jakob H. Heidelberg said...

Hi Mike,

I'd really like to help you out tweaking the code, but as things look right now I simply don't have the time - very sorry!

If time should arise out of nowhere, I'll post the solutions for your requests here. I can't promise you anything right now.

Best regards
Jakob

eglzfan said...

Necessity is the mother of invention, I guess. Here's what I came up with, and it seems to work well. I didn't solve problem #2, but it's no big deal to copy and paste:

Sub GetEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmails As String

Set objFolder = Application.GetNamespace("Mapi").PickFolder
strEmails = GetEmailAddressesInFolder(objFolder, "")
Debug.Print strEmails
End Sub

Function GetEmailAddressesInFolder(objFolder As Object, strEmails As String)
Dim strEmail As String
Dim strOutput As String
Dim objItem As Object
Dim objSubFolder As Object

strOutput = strEmails

For Each objSubFolder In objFolder.Folders
strOutput = GetEmailAddressesInFolder(objSubFolder, strOutput)
Next

For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If InStr(strEmails, strEmail) = 0 Then strOutput = strOutput + ";" + strEmail
End If
Next

GetEmailAddressesInFolder = strOutput
End Function

md said...

Problem 2

Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\temp\testfile.txt", True)


For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
strSender = objItem.SenderName


If InStr(strEmails, strEmail) = 0 Then
a.WriteLine strSender & ", " & strEmail


End If
End If
Next
a.Close

md said...

Problem 2

Sub GetEmailAddressesInFolder()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strSender As String
Dim strEmails As String
Dim objItem As Object
Dim fs, a

Set objFolder = Application.GetNamespace("Mapi").PickFolder

Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\temp\testfile.txt", True)


For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
strSender = objItem.SenderName


If InStr(strEmails, strEmail) = 0 Then
a.WriteLine strSender & ", " & strEmail


End If
End If
Next
a.Close
End Sub

Lateef said...

Thank you so much for this code!!!

In case you want to insert a line break after each e-mail address (instead of the semicolon) - here's the code:

Sub GetEmailAddressesInFolder()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objItem As Object

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 & Chr$(13)
End If
Next
Debug.Print strEmails
End Sub