Excel to Outlook Distribution List Macro RRS feed

  • Question

  • Hi All,

    I have been using this code I found at,, to successfully convert my excel mailing list to a distribution list in my local contacts folder.  However, I would like to actually update a distribution list in my company's public folder.  How would I amend the code accordingly?


    Const DISTLISTNAME As String = "David Mailing List"
    Const olDistributionListItem = 7
    Const olFolderContacts = 10
    Private Sub 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
          .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
          newDistList.AddMember objRcpnt
        Next i
    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

    • Moved by ArthurZ Thursday, September 27, 2012 9:35 PM Does not relate to SSIS (From:SQL Server Integration Services)
    Thursday, September 27, 2012 8:32 PM


  • Hi MacroStar,

    Thanks for posting in the MSDN Forum.

    In you issue you need have permission to access the public folder. Then get the Public folder instead of Contacts folders. Following snippet used to access public folder.

    Public Function GetPublicFolder(strFolderPath)
    	Dim colFolders
    	Dim objFolder
    	Dim arrFolders
    	Dim i
    	On Error Resume Next
    	strFolderPath = Replace(strFolderPath, "/", "")
    	arrFolders = Split(strFolderPath, "")
    	Set objFolder = Application.Session.GetDefaultFolder(18)
    	Set objFolder = objFolder.Folders.Item(arrFolders(0))
    	If Not objFolder Is Nothing Then
    		For i = 1 To UBound(arrFolders)
    			Set colFolders = objFolder.Folders
    			Set objFolder = Nothing
    			Set objFolder = colFolders.Item(arrFolders(i))
    			If objFolder Is Nothing Then 
    				Exit For
    			End If 
    	End If
    	Set GetPublicFolder = objFolder    
    	Set colFolders = Nothing     
    	Set objApp = Nothing    
    	Set objFolder = NothingEnd 

    Have a good day,


    Tom Xu [MSFT]
    MSDN Community Support | Feedback to us

    Friday, September 28, 2012 6:42 AM