Outlook 배포 목록에 연락처 추가

Question

나는 공통된 직책을 각각 선택하여 1000 명이 넘는 연락처를 가지고 있습니다. 각 직책 그룹 (예 : 'Managing Director'직책을 가진 모든 연락처)을 배포 목록 (예 : 'Managing Director')에 프로그래밍 방식으로 추가하고 싶습니다.

Answer 1

다음은 기본 연락처 폴더의 예입니다. 마찬가지로 DL을 만들 수있는 폴더가 있는지 확인하기 위해 기본 연락처 폴더부터 시작하여 DL이있는 모든 폴더로 이동해야합니다. 시도 (전망 VBA IN) 테스트 완료

는

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