Contatos.xslm

' Create multiple Outlook distribution lists from Excel spreadsheet
' by Andy Younie http://www.planetmediocrity.com
' Heavily based on JP's code which can be found at
' http://www.jpsoftwaretech.com/automatically-update-outlook-distribution-lists-from-excel/
 
Const olDistributionListItem = 7
Const olFolderContacts = 10
 
Sub MaintainDistList()
 
Dim DNAME As String ' Distribution list name
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 x As Long ' Counter for groups
 
Set outlook = GetOutlookApp
Set contacts = GetItems(GetNS(outlook))
 
' Count how many groups there are in the list
numRows = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
 
' Start loop to create distribution list for each group
For x = 3 To numRows 'First group is on line 3 of the spreadsheet
 
' Set DNAME to the group name in column A
DNAME = ActiveSheet.Cells(x, "A").Value
 
On Error Resume Next
Set myDistList = contacts.Item(DNAME)
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 = DNAME
.Body = DNAME
End With
 
' loop through worksheet and add each member to dist list
' assume active sheet
numCols = ActiveSheet.Cells(x, "A").CurrentRegion.Columns.Count - 1
 
ReDim arrData(1 To 1, 1 To numCols)
 
' take Group Names out of range
Set rng = ActiveSheet.Range("A1").CurrentRegion.Offset(x - 1, 1).Resize(1, numCols)
' put range into array
arrData = rng.Value
 
' assume 1 row with a variable number of columns
For i = 1 To numCols
Set objRcpnt = outlook.Session.CreateRecipient(arrData(1, i))
 
objRcpnt.Resolve
newDistList.AddMember objRcpnt
Next i
 
newDistList.Save
 
' End loop to create distribution list for each group
Next x
End Sub
 
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = CreateObject("Outlook.Application")
End Function
 
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