Updating Distribution lists in a shared mailbox from Excel

Question

I have the following macro that takes a list of email addresses in Excel and creates/updates an Outlook distribution list under the 'My Contacts' section in Outlook.

How can I adapt this code so that it creates/updates the contacts in a shared mailbox called "Shared Test" instead of just on my mailbox?

Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Sub test() 'Worksheet_Change(ByVal Target As Range)

Dim outlook As Object ' Outlook.Application
Dim contacts As Object ' Outlook.Items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' Outlook.Recipient
Dim arrData() As Variant
Dim rng As Excel.Range
Dim numRows As Long
Dim numCols As Long
Dim i As Long
Dim msg As String

msg = "Worksheet has been changed, would you like to update distribution list?"

  If MsgBox(msg, vbYesNo) = vbNo Then
    Exit Sub
  End If

  Set outlook = GetOutlookApp
  Set contacts = GetItems(GetNS(outlook))

  'On Error Resume Next
  Set myDistList = contacts.Item(DISTLISTNAME)
  On Error GoTo 0

  If Not myDistList Is Nothing Then
    ' delete it
    myDistList.Delete
  End If

    ' recreate it
    Set newDistList = outlook.CreateItem(olDistributionListItem)

    With newDistList
      .DLName = DISTLISTNAME
      .Body = DISTLISTNAME
    End With

    ' loop through worksheet and add each member to dist list
    numRows = Range("A1").CurrentRegion.Rows.Count - 1
    numCols = Range("A1").CurrentRegion.Columns.Count

    ReDim arrData(1 To numRows, 1 To numCols)

    ' take header out of range
    Set rng = Range("A1").CurrentRegion.Offset(1, 0).Resize(numRows, numCols)
    ' put range into array
    arrData = rng.Value

    ' assume 2 cols (name and emails only)
    For i = 1 To numRows
      'little variation on your theme ...
      Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 1) & "<" & arrData(i, 2) & ">")
      'end of variation
      objRcpnt.Resolve
      newDistList.AddMember objRcpnt
    Next i

    newDistList.Save
    'newDistList.Display

End Sub

Function GetOutlookApp() As Object
  'On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

'To My Contacts
Function GetItems(olNS As Object) As Object
Set GetItems = olNS.GetDefaultFolder(olFolderContacts).Items
End Function

Function GetNS(ByRef app As Object) As Object
  Set GetNS = app.GetNamespace("MAPI")
End Function

First good step would be to get rid of all those `On Error Resume Next` and show us what actual errors your code produces. I never understood why people do this. Why would you not want to know, where the errors within your code lie? — Samuel Hulla, Jul 09 '18 at 11:25
Hi, Thank you for the response. However, the code above doesn't error and works perfectly for uploading contacts into 'My contacts' on my mailbox. But i'm am look for a way to make it upload the contacts to a shared mailbox, so wondering how to adapt the code for this. — Stuart Gray, Jul 09 '18 at 12:21
well if it does work perfectly, why don't you remove those expressions? Would only make the matter at hand easier for us so we don't have to anticipate anything is inheritly wrong with your code — Samuel Hulla, Jul 09 '18 at 12:22
Yes, i will thank you. good advice. I'm new'ish to VBA and just found the above on another forum, but just wondering how this can be adapted. thanks — Stuart Gray, Jul 09 '18 at 12:23
`On Error Resume Next` is is heavily misused so most of the time the advice from Rawrplus would be valid. http://www.cpearson.com/excel/errorhandling.htm. The first use of `On Error Resume Next` is beneficial. You will find you have to keep it uncommented. Be careful to only bypass errors you know about, and will handle or not as needed. The second instance of `On Error Resume Next` is neither beneficial nor harmful. — niton, Jul 13 '18 at 00:29
To reference a non default folder https://stackoverflow.com/questions/9076634/get-reference-to-additional-inbox The answer using .CreateRecipient will reference a folder whether it is in the navigation pane or not. As indicated here https://stackoverflow.com/questions/29326940/create-a-contact-in-a-non-default-outlook-contact-folder use `Add` not `Create` for non default folders. — niton, Jul 13 '18 at 00:30

score 0 · Answer 1 · answered Sep 05 '18 at 20:39

One way to reference a non-default folder is with .CreateRecipient.

The functions in your code do not appear to make it more efficient.

Option Explicit

Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Sub test()

    Dim outlook As Object       ' Outlook.Application
    Dim olNs As Object          ' Outlook.Namespace

    Dim shareRecipient As Object            ' outlook.recipient
    Dim sharedMaiboxContacts As Object      ' outlook.Folder
    Dim sharedMaiboxContactsItems As Object ' outlook.items

    Dim myDistList As Object    ' Outlook.DistListItem
    Dim newDistList As Object   ' Outlook.DistListItem

    Dim objRcpnt As Object      ' outlook.recipient

    Set outlook = CreateObject("Outlook.Application")
    Set olNs = outlook.GetNamespace("MAPI")

    ' Enter mailbox name in "sharedMailboxName"
    ' Email address is not as useful. Even if invalid, cannot fail a resolve

    Set shareRecipient = olNs.CreateRecipient("sharedMailboxName")

    shareRecipient.Resolve

    If shareRecipient.Resolved Then

        Set sharedMaiboxContacts = olNs.GetSharedDefaultFolder(shareRecipient, olFolderContacts)
        sharedMaiboxContacts.Display
        Set sharedMaiboxContactsItems = sharedMaiboxContacts.Items

        ' This is a valid use of On Error Resume Next
        '  to bypass a known possible error
        '
        ' Before finalizing the code, test with this commented out
        '  where you think there should not be an error
        '  or you may bypass unknown errors, for example when the syntax is wrong.
        On Error Resume Next

        ' A possible known error occurs if the list does not exist.
        ' myDistList can remain "Nothing" instead of causing an error.
        Set myDistList = sharedMaiboxContactsItems.Item(DISTLISTNAME)

        ' Turn the bypass off. / Turn normal error handling on.
        ' Place it as soon as possible after On Error Resume Next
        On Error GoTo 0

        If Not myDistList Is Nothing Then
            ' delete it
            myDistList.Delete
        End If

        ' Add to non default folders
        Set newDistList = sharedMaiboxContactsItems.Add(olDistributionListItem)

        With newDistList
            .DLName = DISTLISTNAME
            .body = DISTLISTNAME
        End With

        Debug.Print olNs.CurrentUser

        ' Test with yourself
        Set objRcpnt = olNs.CreateRecipient(olNs.CurrentUser)

        objRcpnt.Resolve

        If objRcpnt.Resolved Then
            newDistList.AddMember objRcpnt
            newDistList.Display
        Else
            Debug.Print objRcpnt & " not resolved."
        End If

    Else

        Debug.Print shareRecipient & " not resolved."

    End If

End Sub

Updating Distribution lists in a shared mailbox from Excel

1 Answers1