VB Forum / COM / October 2004

Public Sub cmdOk_Click()
   Dim objApp As Outlook.Application
   Dim objNS As Outlook.NameSpace
   Dim objCFolder As MAPIFolder
   Dim objFolder As MAPIFolder
   Dim oContact As ContactItem
   Dim Mail As MailItem
   Dim DistList As DistListItem
   Dim DistList1 As DistListItem
   Me.Hide
   Set objApp = CreateObject("Outlook.Application")
   Set objNS = objApp.GetNamespace("MAPI")
   Set objDistList = CreateObject("Redemption.SafeDistList")
   Set objDistList1 = CreateObject("Redemption.SafeDistList")
   Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
   Set objContact = CreateObject("Redemption.SafeContactItem")
   Set objMail = CreateObject("Redemption.SafemailItem")
   Set DistList = CreateItem(olDistributionListItem)
   Set DistList1 = CreateItem(olDistributionListItem)
   Set Mail = CreateItem(olMailItem)
   objMail.Item = Mail
   objDistList.Item = DistList
   objDistList1.Item = DistList1
   objContact.Item = oContact
   
   objDistList.Item.ShowCategoriesDialog
For Each oContact In objFolder.Items
If oContact.Categories = DistList.Categories Then
   If oContact.Email1Address <> "" Then
       objMail.Recipients.Add (oContact.Email1Address)
   End If
   If oContact.Email2Address <> "" Then
       objMail.Recipients.Add (oContact.Email2Address)
   End If
   If oContact.Email3Address <> "" Then
       objMail.Recipients.Add (oContact.Email3Address)
   End If
End If
DistList.AddMembers Mail.Recipients
On Error Resume Next
Next
For Each objCFolder In objFolder.Folders
   For Each oContact In objCFolder.Items
   If oContact.Categories = DistList.Categories Then
       If oContact.Email1Address <> "" Then
           Mail.Recipients.Add (oContact.Email1Address)
       End If
       If oContact.Email2Address <> "" Then
           Mail.Recipients.Add (oContact.Email2Address)
       End If
       If oContact.Email3Address <> "" Then
           Mail.Recipients.Add (oContact.Email3Address)
       End If
   End If
   DistList.AddMembers Mail.Recipients
   On Error Resume Next
   Next
   objNS.Folders.GetNext
Next

strAsk = MsgBox("Do you want to add any other types of a contact to this
list?", vbYesNo + vbInformation, "Contacts2Distribute")
If strAsk = vbYes Then

DistList1.ShowCategoriesDialog

For Each oContact In objFolder.Items
If oContact.Categories = DistList1.Categories Then
   If oContact.Email1Address <> "" Then
       Mail.Recipients.Add (oContact.Email1Address)
   End If
   If oContact.Email2Address <> "" Then
       Mail.Recipients.Add (oContact.Email2Address)
   End If
   If oContact.Email3Address <> "" Then
       Mail.Recipients.Add (oContact.Email3Address)
   End If
End If
DistList.AddMembers Mail.Recipients
On Error Resume Next
Next
For Each objCFolder In objFolder.Folders
   For Each oContact In objCFolder.Items
   If oContact.Categories = DistList1.Categories Then
       If oContact.Email1Address <> "" Then
           Mail.Recipients.Add (oContact.Email1Address)
       End If
       If oContact.Email2Address <> "" Then
           Mail.Recipients.Add (oContact.Email2Address)
       End If
       If oContact.Email3Address <> "" Then
           Mail.Recipients.Add (oContact.Email3Address)
       End If
   End If
   DistList.AddMembers Mail.Recipients
   On Error Resume Next
   Next
   objNS.Folders.GetNext
Next
MsgBox "Thank you for your time.", , "Contacts4Distribution"
Else
MsgBox "Thank you for your time.", , "Contacts4Distribution"
End If

objDistList.Subject = objDistList.Categories
objDistList.Display
frmDone.Show
   
   Set objApp = Nothing
   Set objNS = Nothing
   Set objCFolder = Nothing
   Set objFolder = Nothing
   Set Mail = Nothing
   Set DistList = Nothing
   Set oContact = Nothing
   Set DistList1 = Nothing
End Sub