VBA Outlook - Get Emails By Group Name

Wanted to see if it's possible to export email addresses for a specific group?

Looking for VBA code.  

LVL 16
carsRSTAsked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
Chris BottomleyConnect With a Mentor Commented:
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
 
Chris BottomleyCommented:
>>> export email addresses for a specific group

More than likely but can you define  group?

Chris
0
 
carsRSTAuthor Commented:
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
Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

 
carsRSTAuthor Commented:
I'm open to any other known way (as opposed to VBA).
0
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
>>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
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
Thanks, Chris!

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

0
 
carsRSTAuthor Commented:
>>I apologize, but I won't be able to test tomorrow.

should be...

...I won't be able to test until tomorrow.
0
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
Yup ... do I take it that it didn't work and if so what ia the structure of the list?

Chris
0
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
>>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
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
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
 
carsRSTAuthor Commented:
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
 
Chris BottomleyCommented:
Instead of:

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

Chris
0
 
carsRSTAuthor Commented:
Thanks, Chris.  I'll try it.
0
All Courses

From novice to tech pro — start learning today.