none
Excel to Outlook Distribution List Macro RRS feed

  • Question

  • Hi All,

    I have been using this code I found at, http://www.jpsoftwaretech.com/automatically-update-outlook-distribution-lists-from-excel/, 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?

    Greg

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

Answers

  • 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 
    		Next
    	End If
    	Set GetPublicFolder = objFolder    
    	Set colFolders = Nothing     
    	Set objApp = Nothing    
    	Set objFolder = NothingEnd 
    Function

    Have a good day,

    Tom


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


    Friday, September 28, 2012 6:42 AM
    Moderator