Outlook distributrion List in Public folder

[ChrisOswald]

In Office 2003, I'm needing to be able to loop through all the distribution lists in a public folder and return the email addresses associated with each list.

This vbscript from http://technet.microsoft.com/en-us/library/ee692878.aspx works only for the default contacts folder.

Const olFolderContacts = 10
 
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
 
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
intCount = colContacts.Count
 
For i = 1 To intCount
    If TypeName(colContacts.Item(i)) = "DistListItem" Then
        Set objDistList = colContacts.Item(i)
        Wscript.Echo objDistList.DLName
        For j = 1 To objDistList.MemberCount
    Wscript.Echo objDistList.GetMember(j).Name & " -- " & _
               objDistList.GetMember(j).Address
        Next 
        Wscript.Echo
    End If
Next

If my public folder containing these items is

\\Public Folders\All Public Folders\CityName\Division Name\Pricing Support

how would I modify to have it use this folder instead of the

 

[ChrisOswald]

Figured it out.

First (and largest) piece of confusion on my part. I didn't realize that the contact list within the folder was actually another folder. The folder location should have been:

\\Public Folders\All Public Folders\CityName\Division Name\Pricing Support\Email List

Once I realized that, it was just a matter of "Pushing more buttons" to come with a solution.

Sub GetContactsListings()
    Dim ObjOutlook                  As Object
    Dim ColContacts                 As Object
    Dim ObjDistList                 As Object
    Dim myFolder                    As Object
    Dim IntCount                    As Long
    Dim j                           As Long
    Dim i                           As Long
    Dim MyFolderName                As String
    MyFolderName = "Public Folders\All Public Folders\CityName\Division Name\Pricing Support\Email List"
    Set ObjOutlook = CreateObject("Outlook.Application")
    Set myFolder = GetOLFolder(MyFolderName)
    Set ColContacts = myFolder.Items
    IntCount = ColContacts.Count
    For i = 1 To IntCount
        If TypeName(ColContacts.Item(i)) = "DistListItem" Then
            Set ObjDistList = ColContacts.Item(i)
Debug.Print ObjDistList.DLName
            For j = 1 To ObjDistList.MemberCount
Debug.Print ObjDistList.GetMember(j).Name & " -- " & _
            ObjDistList.GetMember(j).Address
            Next
        End If
    Next
    Set ObjDistList = Nothing
    Set ColContacts = Nothing
    Set myFolder = Nothing
    Set ObjOutlook = Nothing
End Sub
 
Public Function GetOLFolder(strFolderPath As String) As Object    'MAPIFolder
' strFolderPath needs to be something like
'   "Public Folders\All Public Folders\Company\Sales" or
'   "Personal Folders\Inbox\My Folder"
 
'This was modified from something I found on the Internet.
'Unfortunately, I lost who the orignal author is.
 
    Dim objApp                      As Object    'Outlook.Application
    Dim objNS                       As Object    'Outlook.Namespace
    Dim colFolders                  As Object    'Outlook.Folders
    Dim objFolder                   As Object    'Outlook.MAPIFolder
    Dim arrFolders()                As String
    Dim i                           As Long
    On Error Resume Next
    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders() = Split(strFolderPath, "\")
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objFolder = objNS.Folders.Item(arrFolders(0))
    If Not objFolder Is Nothing Then
        For i = 1 To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.Item(arrFolders(i))
            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If
 
    Set GetOLFolder = objFolder
    Set objFolder = Nothing
    Set colFolders = Nothing
    Set objNS = Nothing
    Set objApp = Nothing
 
End Function

Now all I have to do is change the sub to a function that returns a list of email contacts based on account number. All of the .name contain an account number, so it should be easy enough to write that function.

 

[Kubus72]

Hallo from germany,

how can I use the vb code with another contacts as my own? I have two Mailboxes: personal and Team-Mailbox. The Team-Mailbox have te same structure as my own. I have also a contact-Folder (Kontakte) in the Team-Mailbox. In the Kontakte are a few distributions list.

How can I use the distribution lists "005 Biogas" from the Team-Mailbox?

Code:

Set ObjOutlook = CreateObject("Outlook.Application")
Set objNameSpace = ObjOutlook.GetNamespace("MAPI")
Set ColContacts = objNameSpace.Folders("Postfach - VAKG").Folders("Kontakte").Items("005 Biogas")

'It doesn't work..
IntCount = ColContacts.Count

i = 0
For i = 1 To IntCount
If TypeName(ColContacts.Item(i)) = "DistListItem" Then
Set ObjDistList = ColContacts.Item(i)
sEmails = ""
If ObjDistList.DLName = sDistName Then
For j = 1 To ObjDistList.MemberCount
sEmails = sEmails & ";" & ObjDistList.GetMember(j).Address
Next

With the Personal Contacts works perfect:

Const olFolderContacts = 10

'DistList
sDistName = "List 2012"

Set ObjOutlook = CreateObject("Outlook.Application")
Set objNameSpace = ObjOutlook.GetNamespace("MAPI")
Set ColContacts = objNameSpace.GetDefaultFolder(olFolderContacts).Items

IntCount = ColContacts.Count

Best regards
Arthur