Referecia.xslm

Private Sub AList_AfterUpdate()
On Error Resume Next

    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myDistList As Outlook.DistListItem
    Dim myTempItem As Outlook.MailItem
    Dim myRecipients As Outlook.Recipients
    Dim objcontacts As Outlook.MAPIFolder
    Dim objcontact As Outlook.ContactItem
    Dim myid, myname As String
    
If Me.AList = True Then 'if true add, if not remove

    'check to see if list already exists
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myDistList = objcontacts.Items("" & Me.Label273.Caption)
    If Err.Number = -2147221233 Then
    GoTo Createmylist
    Err.Clear
    Else
    GoTo addtolist
    End If
    Exit Sub
    
    
Createmylist:
    myid = Me.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = myOlApp.CreateItem(olDistributionListItem)
    
    myname = objcontact.FullName
    myDistList.DLName = "" & Me.Label273.Caption
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
    GoTo mycleanup
    
    
addtolist:
    myid = Me.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = objcontacts.Items("" & Me.Label273.Caption)

    myname = objcontact.FullName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
   GoTo mycleanup
   
Else ' remove in unchecked

'check to see if list already exists
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myDistList = objcontacts.Items("" & Me.Label273.Caption)
    If Err.Number = -2147221233 Then
    Err.Clear
    Exit Sub
    Else
    myid = Me.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    Set myDistList = objcontacts.Items("" & Me.Label273.Caption)
    End If

    myname = objcontact.FullName
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.RemoveMembers myRecipients
    myDistList.Close olSave
   
   
   'check to see if list is populated, delete if empty
   If myDistList.MemberCount = 0 Then
   myDistList.Delete
   End If
   

End If


mycleanup:
    Set myOlApp = Nothing
    Set myNameSpace = Nothing
    Set myDistList = Nothing
    Set myTempItem = Nothing
    Set myRecipients = Nothing
    Set objcontacts = Nothing
    Set objcontact = Nothing
    
    
End Sub