• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 183
  • Last Modified:

outlook extract from active directory

Hello
I need help in this outlook vba piece. I have a contact group in outlook  that has several individual contact emails . How can loop through each contact in the contact group and extract out the name, position of the individual?
Thank you
0
Rayne
Asked:
Rayne
  • 7
  • 5
1 Solution
 
David LeeCommented:
Hi, Rayne.

Assuming that you have Outlook 2007 or later, then this should do it.

Sub Parse_AD_DL(strAddress As String)
    Dim olkRec As Outlook.Recipient, olkAE As Outlook.AddressEntry, olkDL As Outlook.ExchangeDistributionList, olkMem As Outlook.AddressEntry
    Set olkRec = Session.CreateRecipient(strAddress)
    olkRec.Resolve
    Set olkAE = olkRec.AddressEntry
    Set olkDL = olkAE.GetExchangeDistributionList
    For Each olkMem In olkDL.Members
        'Your code goes here for processing the members in the list
        Debug.Print olkMem.Name
    Next
    Set olkDL = Nothing
    Set olkAE = Nothing
    Set olkRec = Nothing
End Sub

Open in new window


You'll need to pass the address of the list you want to process to the sub.
0
 
RayneAuthor Commented:
Hello BlueDevilFan,

I created the contact group locally in my outlook new items >> more items >> contact group,

 i didn't create a distribution list within the outlook server - will that work then?
0
 
RayneAuthor Commented:
and i want to loop through contact group...
0
Easily manage email signatures in Office 365

Managing email signatures in Office 365 can be a challenging task if you don't have the right tool. CodeTwo Email Signatures for Office 365 will help you implement a unified email signature look, no matter what email client is used by users. Test it for free!

 
David LeeCommented:
No, the code I posted is for a distribution list in Active Directory, which is what you'd asked for.  I can put together the code for a dist list in Outlook if that's what you need.  I don't understand your last comment, "loop through contact group".  Do you mean you want to loop through the members of the group?  If so, what do you want to do with each member?
0
 
RayneAuthor Commented:
its not a distribution list in outlook server but i created one contact group  in my outlook like attached image....
contactGroup.bmp
0
 
RayneAuthor Commented:
i need to get the name, title/position of the contacts
0
 
RayneAuthor Commented:
Do you mean you want to loop through the members of the group?  I
YES
0
 
David LeeCommented:
What do you want to do with the name and title of each contact?  Display it on screen, write it to a file, ...?
0
 
RayneAuthor Commented:
Hello BluedevilFan,
Sorry for the delay, some personal issues happened.

so for each member, get his title/position and name and put it in a excel sheet
0
 
David LeeCommented:
Please try this version.

Sub Parse_AD_DL(strAddress As String)
    Dim olkRec As Outlook.Recipient, _
        olkAE As Outlook.AddressEntry, _
        olkDL As Outlook.ExchangeDistributionList, _
        olkMem As Outlook.AddressEntry, _
        olkUsr As Outlook.ExchangeUser, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long
    Set olkRec = Session.CreateRecipient(strAddress)
    olkRec.Resolve
    If olkRec.Resolved Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        With excWks
            .Cells(1, 1) = "Title/Position"
            .Cells(1, 2) = "Name"
        End With
        lngRow = 2
        Set olkAE = olkRec.AddressEntry
        Set olkDL = olkAE.GetExchangeDistributionList
        For Each olkMem In olkDL.Members
            Set olkUsr = olkMem.GetExchangeUser
            excWks.Cells(lngRow, 1) = olkUsr.JobTitle
            excWks.Cells(lngRow, 2) = olkUsr.Name
            lngRow = lngRow + 1
        Next
        excWks.Columns("A:B").AutoFit
        excWkb.SaveAs Environ("USERPROFILE") & "\Documents\" & strAddress & ".xlsx"
        excWkb.Close False
    End If
    Set olkRec = Nothing
    Set olkAE = Nothing
    Set olkDL = Nothing
    Set olkMem = Nothing
    Set olkUsr = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkRec = Nothing
End Sub

Open in new window

0
 
RayneAuthor Commented:
thank you Bluedevilfan :)
0
 
David LeeCommented:
You're welcome!
0

Featured Post

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.

  • 7
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now