將聯繫人添加到Outlook發佈清單

Question

我有1000多個聯繫人，每個聯繫人都有一組常用職位。我希望以編程方式將每個職位組（例如所有與職位名稱'總經理'的聯繫人）添加到分配名單（例如'總經理'）中。

Answer 1

好的，這裏只是默認聯繫人文件夾的一個例子。同樣，您必須前往DL可能存在的每個文件夾，從默認聯繫人文件夾開始，在創建Dist列表之前檢查它是否存在。

嘗試和測試（在Outlook VBA）

Option Explicit 

Sub GetJobList() 
    Dim olApp As Outlook.Application 
    Dim olNmspc As Outlook.NameSpace 
    Dim olAdLst As Outlook.AddressList 
    Dim olAdLstEntry As Outlook.AddressEntry 
    Dim olDLst As Outlook.DistListItem, olDLstItem As Outlook.DistListItem 
    Dim olMailItem As Outlook.MailItem 
    Dim olRecipients As Outlook.Recipients 

    Dim jobT() As String, JobTitle As String 
    Dim i As Long 

    Set olApp = New Outlook.Application 
    Set olNmspc = olApp.GetNamespace("MAPI") 

    i = 0 

    '~~> Loop through the address entries 
    For Each olAdLst In olNmspc.AddressLists 
     Select Case UCase(olAdLst.Name) 
      Case "CONTACTS" 
       '~~> Get the Job Title 
       For Each olAdLstEntry In olAdLst.AddressEntries 
        On Error Resume Next 
        JobTitle = Trim(olAdLstEntry.GetContact.JobTitle) 
        On Error GoTo 0 

        If JobTitle <> "" Then 
         ReDim Preserve jobT(i) 
         jobT(i) = olAdLstEntry.GetContact.JobTitle 
         i = i + 1 
        End If 
       Next 
     End Select 
    Next 

    '~~> Loop through the job title to create the distribution lists 
    For i = LBound(jobT) To UBound(jobT) 
     '~~> Check if the DL List exists 
     On Error Resume Next 
     Set olDLst = olNmspc.GetDefaultFolder(olFolderContacts).Items(jobT(i)) 
     On Error GoTo 0 

     '~~> If not then create it 
     If olDLst Is Nothing Then 
      Set olDLst = olApp.CreateItem(7) 
      olDLst.DLName = jobT(i) 
      olDLst.Save 
     End If 
    Next i 

    '~~> Loop through the address entries to add contact to relevant Distribution list 
    For Each olAdLst In olNmspc.AddressLists 
     Select Case UCase(olAdLst.Name) 
      Case "CONTACTS" 
       '~~> Get the Job Title 
       For Each olAdLstEntry In olAdLst.AddressEntries 
        On Error Resume Next 
        JobTitle = Trim(olAdLstEntry.GetContact.JobTitle) 
        On Error GoTo 0 

        If JobTitle <> "" Then 
         On Error Resume Next 
         Set olDLst = olNmspc.GetDefaultFolder(olFolderContacts).Items(JobTitle) 
         On Error GoTo 0 

         '~~> Create a mail item 
         Set olMailItem = olApp.CreateItem(0) 
         Set olRecipients = olMailItem.Recipients 
         olRecipients.Add olAdLstEntry.GetContact.Email1Address 

         '~~> Add to distribution list 
         With olDLst 
          .AddMembers olRecipients 
          .Close olSave 
         End With 

         Set olMailItem = Nothing 
         Set olRecipients = Nothing 
        End If 
       Next 
     End Select 
    Next 

    Set olNmspc = Nothing 
    Set olApp = Nothing 
    Set olDLst = Nothing 

End Sub