Outlook Public Folder and Distribution List 1

[alan12345]

I am programming using the Outlook Object Model.

I can programmatically add contacts to a Public Contacts folder.

I can also programmatically create the distribution list.

But I cannot programmatically add contacts to my distribution list.

Any ideas why the code below does not add the contacts to the dist list?

Here is my code:

Private Sub cmdAdd_Click()
On Error Resume Next

Dim sysPath As String, sSrv As String, sFN As String, sOpenSTR As String
Dim adoCon As New ADODB.Connection
Dim adoRS As New ADODB.Recordset

sysPath = App.Path
If InStr(1, UCase(sysPath), "EXECRAS") Then
sSrv = "RING01" 'SQL production Database
Else
sSrv = "RING36" 'SQL test Database
End If

sFN = "Associates"

strFolderPath = "Public Folders\All Public Folders\" & sFN

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 arrFolders(I) = sFN Then
objFolder.ShowAsOutlookAB = True

Set objDL = objFolder.Items.Add(Outlook.OlItemType.olDistributionListItem)
objDL.DLName = sFN
objDL.Save

adoCon.ConnectionString = "driver={SQL Server};" & _
"server=" & sSrv & ";Trusted_Connection=Yes;database=RAS"
If sFN = "Associates" Then
sOpenSTR = "'ASSOC'"
Else
sOpenSTR = "'CRS'"
End If


adoRS.Open "Exec RES_AddAssocOrCRS " & sOpenSTR, adoCon.ConnectionString, adOpenDynamic, adLockPessimistic

If Not (adoRS.BOF And adoRS.EOF) Then
adoRS.MoveFirst
Do Until adoRS.EOF
Set objCI = objFolder.Items.Add(olContactItem)

With objCI
.FirstName = adoRS("Fname")
.LastName = adoRS("Lname")
.Email1Address = adoRS("Email_Address")
.Email1DisplayName = adoRS("Display_Name")
.SelectedMailingAddress = olHome
.Categories = sFN
.Save
End With

Set myMailItem = objApp.CreateItem(Outlook.OlItemType.olMailItem)
Set oRecipients = myMailItem.Recipients 'Resolve the current user just added by Email Address
oRecipients.Add (objCI.Email1Address) 'Add Contact Item as a recipient
oRecipients.ResolveAll

objDL.AddMembers (oRecipients) ' if count > 109 - it bombs
objDL.Display

Set objCI = Nothing 'in next Iteration
Set oRecipients = Nothing 'Empty Contact Item and Recipient Item


adoRS.MoveNext
Loop

End If
End If

If objFolder Is Nothing Then
Exit For
End If
Next I
End If

Set objDL = Nothing

Set adoRS = Nothing
Close adoCon
Set adoCon = Nothing
Set objFolder = Nothing
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
Unload Me
End Sub


THANKS!!
Alan

 

[comaboy]

You're loop is wrong. You can't (as far as I know) "bulk-add" recipients to a distro-list. You need to AddMember for each recipient to be added.

Pseudo:

Start Loop:
Open RS, Move First
Set objContact as New ContactItem
Do objContact's details
myDistList.AddMember objContact
Set objContact = Nothing
Move Next
End Loop When EOF:
Set all objects to nothing
End:

Here's some code that should set you on the right track.
Ripped from

http://www.dotnet247.com/247reference/msgs/38/190308.aspx

(You need a Reference to Outlook Object Model)

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myDistList As Outlook.DistListItem
Dim myContact As Outlook.ContactItem
Dim myRecipient As Outlook.recipient

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myDistList = myOlApp.CreateItem(olDistributionListItem)
myDistList.DLName = InputBox("Enter the name of the new distributionList ")

Dim item As Object
For Each item In myNameSpace.GetDefaultFolder(olFolderContacts).Items
If TypeOf item Is ContactItem Then
Set myContact = item
Set myRecipient = myNameSpace.CreateRecipient(myContact.FullName)
myRecipient.Resolve
myDistList.AddMember myRecipient
End If
Next
myDistList.Display