vba - 連絡先を Outlook 配布リストに追加する

Question

1000 人以上の連絡先があり、それぞれが一般的な役職を選択しています。各役職グループ (たとえば、役職が「Managing Director」のすべての連絡先) を配布リスト (たとえば、「Managing Director」) にプログラムで追加したいと考えています。

Answer 1

これは、デフォルトの連絡先フォルダーのみの例です。同様に、配布リストを作成する前に、配布リストが存在するかどうかを確認するために、既定の連絡先フォルダーから始めて、DL が存在する可能性のあるすべてのフォルダーに移動する必要があります。

試行およびテスト済み (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