Updating Distribution lists in a shared mailbox from Excel - 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

Answer 1

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