Cascaded DistributionList in VBA Outlook 2003

[HU Steiner]

Hallo
I am programming a VBA-Solution for Export and Import Contacts,
inclusive Distributionslist to and from a Access-DB.
After a lot of minor problems (thanks Sue Mosher and other for the most
solutions) is one without solution:
Cascaded DistributionLists:
- DL1
- Henry Miller
- Sue Mosher
- DL3
- DL1
- Fritz Keller
- Dagobert Duck
I am not able to add DL1 as Member to DL3.
I have tested without 'MAPIPDL:' too.
The Debug.Print Msg ist Resolve impossible'.

My Code below (shorted and simplified):

Thanks
Hans

Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oMFolder As MAPIFolder
Dim oDL As Outlook.DistListItem
Dim oRecipients As Outlook.MailItem 'Recipients-Objekt
für Add
Dim oRecip As Outlook.Recipients 'Recipient-Objekt

Dim xK As Integer
Dim sDLLast As String
Dim sName As String
Dim sNameE As String 'expadded
Dim sEMail As String
Dim sEMailTyp As String
Dim aryK(5, 4) As String

' DL 1
aryK(0, 0) = "DL1"
aryK(0, 1) = "Henry Miller"
aryK(0, 2) = "(e-mail address removed)"
aryK(0, 3) = "SMTP"
aryK(1, 0) = "DL1"
aryK(1, 1) = "Sue Mosher"
aryK(1, 2) = "(e-mail address removed)"
aryK(1, 3) = "SMTP"
' DL 2
aryK(2, 0) = "DL2"
aryK(2, 1) = "Dagobert Duck"
aryK(2, 2) = "(e-mail address removed)"
aryK(2, 3) = "SMTP"
aryK(3, 0) = "DL2"
aryK(3, 1) = "DL1" 'Sub-DL
aryK(3, 2) = ""
aryK(3, 3) = "MAPIPDL"
aryK(4, 0) = "DL99999"

Set oApp = CreateObject("Outlook.Application.11")
Set oNS = oApp.GetNamespace("MAPI")
Set oMFolder = oNS.GetDefaultFolder(olFolderContacts)

For xK = 0 To 3

If aryK(xK, 0) <> sDLLast Then 'new DL
Set oDL = oApp.CreateItem(olDistributionListItem)
oDL.DLName = aryK(xK, 0)
Set oRecipients = oApp.CreateItem(olMailItem)
Set oRecip = oRecipients.Recipients
sDLLast = aryK(xK, 0)
End If
sName = aryK(xK, 1)
sEMail = aryK(xK, 2)
sEMailTyp = aryK(xK, 3)

If sEMailTyp = "MAPIPDL" Then ' Sub-DL
sNameE = "MAPIPDL:" & sName ' <--- ????
Else
sNameE = sName & " (" & sEMail & ")"
End If

oRecip.Add sNameE
If oRecip.ResolveAll = True Then
If oRecip(1).Address <> "" Then
oDL.AddMembers oRecip
Else
Debug.Print "Adress missing: " & sNameE & " EMail: " & sEMail
End If
Else
Debug.Print "Resolve impossible: " & sNameE & " EMail: " & sEMail
End If
oRecip.Remove (1)

If aryK(xK + 1, 0) <> sDLLast Then 'next new DL
oDL.Save
End If
Next

 

[Eric Legault [MVP - Outlook]]

Take a look at my example below. Making DLs can be a little tricky, but when the code is arranged in a logical fashion it becomes a little more clear how it can be done correctly.

Sub CreateDLs()

Dim olApp As Outlook.Application
Dim objDL As DistListItem
Dim objMail As MailItem
Dim objRcpnt As Recipient

Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)

'Create first distlist
Set objDL = olApp.CreateItem(olDistributionListItem)

'Create recipient for distlist
Set objRcpnt = olApp.Session.CreateRecipient("Fred <[email protected]>")
objRcpnt.Resolve
objDL.AddMember objRcpnt
objDL.DLName = "DL1"
objDL.Save

'Create second distlist
Set objDL = olApp.CreateItem(olDistributionListItem)

'create first recipient
Set objRcpnt = olApp.Session.CreateRecipient("Wilma <[email protected]>")
objRcpnt.Resolve
objDL.AddMember objRcpnt

'create second recipient; this is actually the distribution list created above
Set objRcpnt = olApp.Session.CreateRecipient("DL1")
objRcpnt.Resolve
objDL.AddMember objRcpnt

objDL.DLName = "DL2"
objDL.Save

End Sub