Import contacts to a shared mailbox

Not open for further replies.


New Member
Outlook version
Outlook 2013 32 bit
Email Account

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 - and this works perfectly.
However, 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. Any help would be greatly appreciated. Stu

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
End If

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

With newDistList
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
newDistList.AddMember objRcpnt
Next i


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
Not open for further replies.