Distribution list

  • Thread starter Thread starter Robgould
  • Start date Start date
R

Robgould

Guest
I am using this code to add a distribution list to outlook. The problem is, it only works if outlook is already open. Any ideas what I have wrong? If outlook is closed the addmembers fails.

Code: 
Private Sub AList_AfterUpdate()

    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
    
    myid = Me.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myDistList = myOlApp.CreateItem(olDistributionListItem)
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    
    myname = objcontact.FullName
    
    myDistList.DLName = "" & Me.Label273.Caption
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Save
    
    Set myOlApp = Nothing
    Set myNameSpace = Nothing
    Set myDistList = Nothing
    Set myTempItem = Nothing
    Set myRecipients = Nothing
    Set objcontacts = Nothing
    Set objcontact = Nothing
    
    
End Sub
 
When I was doing this sort of thing, I used to use this to make sure all was well with Outlook.


Code: 
' Declare module level variables
Dim mOutlookApp As Outlook.Application
Dim mNameSpace As Outlook.NameSpace
Dim mFolder As MAPIFolder
Dim mItem As MailItem
Dim fSuccess As Boolean
_____________________________________________________________

Private Function GetOutlook() As Boolean
    ' The GetOutlook() function sets the Outlook Application
    ' and Namespase objects and opens MS Outlook
    On Error Resume Next

    ' Assume success
    fSuccess = True
    
    Set mOutlookApp = GetObject("", "Outlook.application")
    
    ' If Outlook is NOT Open, then there will be an error.
    ' Attempt to open Outlook
    If Err.Number > 0 Then
        Err.Clear
        Set mOutlookApp = CreateObject("Outlook.application")
            
        If Err.Number > 0 Then
            MsgBox "Could not create Outlook object", vbCritical
            fSuccess = False
            Exit Function
        End If
    End If

    ' If we've made it this far, we have an Outlook App Object
    ' Now, set the NameSpace object to MAPI Namespace
    Set mNameSpace = mOutlookApp.GetNamespace("MAPI")
    
    If Err.Number > 0 Then
        MsgBox "Could not create NameSpace object", vbCritical
        fSuccess = False
        Exit Function
    End If
    
    ' Return the Success Flag as the value of GetOutlook()
    GetOutlook = fSuccess

I would use it like this(from a sub)...

Code: 
If GetOutlook = True Then
        [I]whatever you want to do[/I]

I can't remember it ever letting me down (think I got the code from somewhere on the net).

Take care.
 
I made this work by modifying the code as below. It now will add the distribution list even if Outlook is closed when the code runs. I had to display the distribution list and then close it. I guess this makes it stay open for the add?? The problem with this is that the user sees the list flash on the screen and then dissapear....just a little unprofessional looking. Any ideas on a better way?

Code: 
    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
    
    myid = Me.IDContact
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myDistList = myOlApp.CreateItem(olDistributionListItem)
    Set myTempItem = myOlApp.CreateItem(olMailItem)
    Set myRecipients = myTempItem.Recipients
    Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
    
    myname = objcontact.FullName
    myDistList.Display
    
    myDistList.DLName = "" & Me.Label273.Caption
    myRecipients.Add "" & myname
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.Close olSave
   
    
    Set myOlApp = Nothing
    Set myNameSpace = Nothing
    Set myDistList = Nothing
    Set myTempItem = Nothing
    Set myRecipients = Nothing
    Set objcontacts = Nothing
    Set objcontact = Nothing
 
Solved. I just had to change the order of the createitem statements. I guess you can only have one open at a time. I rearranged them as below and now all works fine.



Code: 
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
 
Completed code

Thought I would post my completed code in case someone was interested some day. This code uses a check box on my form. If the check box is clicked the user is added to a distribution list in outlook. If the list does not exist it creates it. When the box is unchecked the user is removed from the distribution list. If the resulting list is empy of recipients it is deleted. I use the click yes program to "bypass" outlook security warnings. Here is the code.

Code: 
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
 
You must log in or register to reply here.

Similar threads

D
Check if the first 9 characters of subject line is 'FORMIMAGE'
Replies
10
Views
1,360
Gasman
Gasman
1
E-Mail Fails to Send
Replies
8
Views
980
1268
1
M
outlook email automation
Replies
3
Views
764
megatronixs
M
E
Sending an email
Replies
7
Views
1,232
Orthodox Dave
Orthodox Dave
V
formating and sending emails in access with vba
Replies
2
Views
2,314
Minty
Minty

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom