Solved

VBA Outlook - Get Emails By Group Name

Posted on 2011-03-15
23
863 Views
Last Modified: 2012-05-11
Wanted to see if it's possible to export email addresses for a specific group?

Looking for VBA code.  

0
Comment
Question by:carsRST
  • 13
  • 10
23 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
>>> export email addresses for a specific group

More than likely but can you define  group?

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
Sorry for the confusion.  Group meaning an "email group" or distribution list.  

I need to extract the individual emails out of several very large groups.  

0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
I'm open to any other known way (as opposed to VBA).
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
You want all the members of a distribution list to be exported with SMTP addresses in for example a text document?

Are you on an exchange server or are all addresses stored locally as SMTP?
WHat version of outlook are you using?

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
>>You want all the members of a distribution list to be exported with SMTP addresses in for example a text document?

correct

It's on an exchange server.  My client is 2003 or 2007 - have two machines.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
I was getting there and made a silly mistake losing my work so far.

Someone else may come up sooner but for now I will be further delayed.

Chris
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
Comment Utility
Post the snippet into a normal code module.  Edit as follows:

1. Const outputFilePathandName As String = "c:\deleteme\dl_Addresses.txt"
to a path that already exists and a filename, (.txt) or your choosing

2.     strAddress = "TESTDL"
to the distribution list of your choice

I do not have aces to an exchange server any more so whilst I think I have adressed the exchange addressing I cold be wrong ... and my chances to rsolve may be limited ... though with your feedback (if necessary I will of course try).

Execute sub getAddresses to run the sequence

Chris
Sub getAddresses()
Dim strAddress As String
Dim arrAddresses() As String
Dim intArraySize As Integer
Dim elem As Variant
Dim outputFile As Object
Dim fso As Object
Dim openfile As Object
Const outputFilePathandName As String = "c:\deleteme\dl_Addresses.txt"

    strAddress = "TESTDL"
    ReDim arrAddresses(0)
    getaddresses_recursion strAddress, arrAddresses, intArraySize
    
    If UBound(arrAddresses) >= 1 Or arrAddresses(0) <> "" Then
        Set fso = CreateObject("scripting.filesystemobject")
        If fso.FileExists(outputFilePathandName) Then
            Set openfile = fso.openTextFile(outputFilePathandName, 2, False)
        Else
            Set openfile = fso.openTextFile(outputFilePathandName, 2, True)
        End If
        For Each elem In arrAddresses
            openfile.writeline elem
        Next
    End If
    
End Sub

Sub getaddresses_recursion(strAddress As String, arrAddresses As Variant, intArraySize As Integer)
Dim recip As Object
Dim strName As String
Dim intMemberCount As Integer
Dim dl As Object
Dim varAddresses As Variant
    
    On Error Resume Next
    Set recip = Application.Session.GetDefaultFolder(olFolderContacts).items(strAddress)
    On Error GoTo 0
    
    
    If InStr(strAddress, "@") > 0 Then
        ReDim Preserve arrAddresses(intArraySize)
        arrAddresses(intArraySize) = strAddress
        intArraySize = intArraySize + 1
    ElseIf Not recip Is Nothing Then
        If recip.Class = olDistributionList Then
            For intMemberCount = 1 To recip.MemberCount
                On Error Resume Next
                Set dl = Application.Session.GetDefaultFolder(olFolderContacts).items(CStr(recip.GetMember(intMemberCount)))
                On Error GoTo 0
                If dl Is Nothing Then
                    If InStr(CStr(recip.GetMember(intMemberCount)), "@") > 0 Then
                        ReDim Preserve arrAddresses(intArraySize)
                        arrAddresses(intArraySize) = CStr(recip.GetMember(intMemberCount))
                        intArraySize = intArraySize + 1
                    Else
                        ReDim Preserve arrAddresses(intArraySize)
                        arrAddresses(intArraySize) = GetSMTPAddress(CStr(recip.GetMember(intMemberCount)))
                        intArraySize = intArraySize + 1
                    End If
                Else
                    If dl.Class = olRecipient Then
                        With Application.Session.GetDefaultFolder(olFolderContacts).items(CStr(recip.GetMember(intMemberCount)))
                            If .Class = olRecipient Then
                                If .Email1AddressType = "SMTP" Then
                                    ReDim Preserve arrAddresses(intArraySize)
                                    arrAddresses(intArraySize) = .Email1Address
                                    intArraySize = intArraySize + 1
                                ElseIf .Email1AddressType = "EX" Then
                                    ReDim Preserve arrAddresses(intArraySize)
                                    arrAddresses(intArraySize) = GetSMTPAddress(CStr(recip.GetMember(intMemberCount)))
                                    intArraySize = intArraySize + 1
                                End If
                            Else
                                strName = .GetMember(intMemberCount).name
                                Set dl = Application.Session.GetDefaultFolder(olFolderContacts).items(strName)
                                'Stop
                                getaddresses_recursion dl.DLName, arrAddresses, intArraySize
                            End If
                        End With
                    ElseIf dl.Class = olDistributionList Then
                        strName = recip.GetMember(intMemberCount).name
                        Set dl = Application.Session.GetDefaultFolder(olFolderContacts).items(dl.DLName)
                        'Stop
                        getaddresses_recursion dl.DLName, arrAddresses, intArraySize
                    End If
                End If
            Next
        Else
            If recip.Email1AddressType = "SMTP" Then
                ReDim Preserve arrAddresses(intArraySize)
                arrAddresses(intArraySize) = recip.Email1Address
                intArraySize = intArraySize + 1
            ElseIf recip.Email1AddressType = "EX" Then
                ReDim Preserve arrAddresses(intArraySize)
                arrAddresses(intArraySize) = GetSMTPAddress(strAddress)
                intArraySize = intArraySize + 1
            End If
        End If
    End If

End Sub

Function GetSMTPAddress(ByVal strAddress As String)
' Based on:
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Object
Dim strRet As String
Dim fldr As Object
    
    If InStr(strAddress, "@") > 0 Then
        GetSMTPAddress = strAddress
    Else
        'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
        On Error Resume Next
        Set olApp = Application
        Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
        If fldr Is Nothing Then
            olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Add "Random"
            Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).folders.Item("Random")
        End If
        On Error GoTo 0
        If CInt(Left(olApp.Version, 2)) >= 12 Then
            Set oRec = olApp.Session.CreateRecipient(strAddress)
            If oRec.Resolve Then
                strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
            End If
        End If
        If Not strRet = "" Then GoTo ReturnValue
        'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
        'How it works
        '============
        '1) It will create a new contact item
        '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
        '3) We will assign a random key to this contact item and save it in its Fullname to search it later
        '4) Next we will save it to local contacts folder
        '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
        '6) The display name will be something like this " ( email.address@server.com )"
        '7) Now we need to parse the Display name and delete the contact from contacts folder
        '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
        '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
        Set oCon = fldr.items.Add(2)
        oCon.Email1Address = strAddress
        strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
        oCon.FullName = strKey
        oCon.Save
        strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
        oCon.Delete
        Set oCon = Nothing
        Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
        If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
        GetSMTPAddress = strRet
    End If
    
End Function

Open in new window

0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
Thanks, Chris!

I apologize, but I won't be able to test tomorrow.  I greatly appreciate your effort and help.

0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
>>I apologize, but I won't be able to test tomorrow.

should be...

...I won't be able to test until tomorrow.
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
Thanks again for your help.

Question...so if I have a group/distribution list called "group US controllers" is that what I populate in to the strAddress variable?

0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Yup ... do I take it that it didn't work and if so what ia the structure of the list?

Chris
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 16

Author Comment

by:carsRST
Comment Utility
Yeah, didn't seem to bring back any data.

>>if so what ia the structure of the list?
I really don't get deeply involved in outlook, other than email and calendar.  To answer your question, is there something I can pull out of the properties?

0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
In order ...

1. Is the txt file being created

2. In the DL does it include other DL's or is it only mails.

3. Are the mails all exchange addresses, if yes try adding an SMTP@domain.com address and retry, (delete the address afterwards.

4. If the txt was not created originally ... is it there now?

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
>>1. Is the txt file being created
The code works on this, if I put in a regular address.  But does not create the file if I put in a group name

>>2. In the DL does it include other DL's or is it only mails.
I have two dist. lists.  One is only emails, while the other is made up of 3 dist. lists.

>>3. Are the mails all exchange addresses, if yes try adding an SMTP@domain.com address and retry, (delete the address afterwards.
Yeah, should all be Exchange.  I will try now.
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
I'm still not having much luck, but, after some research, I believe it's on my end.  I think your code is good, so I'm going to close this question.

Thank you again for all your effort.  Can't tell you how much I appreciate it!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Appreciate it's closed but FYI, the script is designed to take embedded distros so that should not be an issue since the getsmtpaddress has been used a lot by me in the past BUT does not mean I haven't made an error somewhere.

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
I believe you answered my original question, so that's why I closed.

One last question, if you don't mind:
Do you know how I can tell if I'm putting in the correct group name to your variable?  I have a display name, alias,  and smtp address.  I've tried all three and none work.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
The one displayed on the card / index list etc.

I am however intersted in what you are saying since between 2010 and XP my two copies have just the one field displayed ... the name.  can you perhaps define how the group is created?

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
I created my own distribution list and your code executed great.  worked perfectly.  

However, doesn't work when I try to use a group created by someone else.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Ah!

I take it the group is not stored in your contacts folder?  The line 37:


    Set recip = Application.Session.GetDefaultFolder(olFolderContacts).items(strAddress)

looks in your contacts folder but can be modified if need be ... possibly even made dynamic not sure how that might work though.  Thought for another day perhaps as I am intrigued!

If you copy teh dl to your contacts folder I presume it will work?

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
Ok - think i'm on to something.  I believe I have to set it somehow to the global address book.  after that, I'm  guessing your code may work.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
Instead of:

Set recip = Application.Session.GetDefaultFolder(olFolderContacts).items(strAddress)
try
Set recip = Application.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).folders("Contacts").items(strAddress)

Chris
0
 
LVL 16

Author Comment

by:carsRST
Comment Utility
Thanks, Chris.  I'll try it.
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Macro to Send Appointment from Excel 1 29
calendar, outlook 2 37
Outlook 2010 Archive 3 36
Emergency issue with outlook 2007 3 23
Find out how to use dynamic social media in email signatures with this top 10 DOs & DON’Ts.
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now