Vba 将联系人添加到Outlook通讯组列表

我有1000多个联系人，每个人都有一些常见的职位。我希望以编程方式将每个职务组（例如，职务为“常务董事”的所有联系人）添加到通讯组列表（例如“常务董事”）中。

确定此处仅举一个默认联系人文件夹的示例。同样，您必须转到可能存在DL的每个文件夹，从默认的Contacts文件夹开始，在创建它之前检查Dist列表是否存在

经过尝试和测试（在OUTLOOK VBA中）

选项显式
子GetJobList（）
Dim olApp作为Outlook.Application
将olNmspc设置为Outlook.NameSpace
Dim olAdLst作为Outlook.AddressList
将olAdLstEntry设置为Outlook.AddressEntry
将olDLst设置为Outlook.DistListItem，将olDLstItem设置为Outlook.DistListItem
将olMailItem设置为Outlook.MailItem
将收件人设置为Outlook。收件人
Dim jobT（）作为字符串，JobTitle作为字符串
我想我会坚持多久
Set olApp=newoutlook.Application
设置olNmspc=olApp.GetNamespace（“MAPI”）
i=0
“~~>循环遍历地址项
对于olNmspc.AddressList中的每个olAdLst
选择案例UCase（olAdLst.Name）
案例“联系人”
“~~>得到这个职位
对于olAdLst.AddressEntries中的每个OLADLSTANTRY
出错时继续下一步
JobTitle=Trim（olAdLstEntry.GetContact.JobTitle）
错误转到0
如果职位名称为“”，则
重播保留作业（一）
jobT（i）=olAdLstEntry.GetContact.JobTitle
i=i+1
如果结束
下一个
结束选择
下一个
“~~>循环浏览职务以创建通讯组列表
对于i=LBound（jobT）到UBound（jobT）
“~~>检查DL列表是否存在
出错时继续下一步
设置olDLst=olNmspc.GetDefaultFolder（olFolderContacts）.Items（作业（i））
错误转到0
“~~>如果不是，则创建它
如果olDLst什么都不是，那么
Set olDLst=olApp.CreateItem（7）
olDLst.DLName=jobT（i）
旧的保存
如果结束
接下来我
“~~>循环浏览地址条目，将联系人添加到相关通讯组列表中
对于olNmspc.AddressList中的每个olAdLst
选择案例UCase（olAdLst.Name）
案例“联系人”
“~~>得到这个职位
对于olAdLst.AddressEntries中的每个OLADLSTANTRY
出错时继续下一步
JobTitle=Trim（olAdLstEntry.GetContact.JobTitle）
错误转到0
如果职位名称为“”，则
出错时继续下一步
设置olDLst=olNmspc.GetDefaultFolder（olFolderContacts）.Items（作业标题）
错误转到0
“~~>创建一个邮件项目
设置olMailItem=olApp.CreateItem（0）
设置olRecipients=olMailItem.Recipients
olRecipients.Add OLADLStantry.GetContact.Email1地址
“~~>添加到通讯组列表
与奥尔德斯特
.AddMembers
.关闭olSave
以
设置olMailItem=Nothing
Set=Nothing
如果结束
下一个
结束选择
下一个
设置olNmspc=无
设置olApp=Nothing
设置olDLst=Nothing
端接头

这很简单。你尝试过什么？我正在尝试一本叫做《Outlook编程圣经》的书中的一些例子，但它们都没有达到我想要的效果，而且我修改代码的运气也不太好。与其尝试修复可能存在严重错误的代码，你提交答案不是更容易吗？我无意修复代码。我已经准备好了代码：）我会在看到你的努力时发布：）我尝试过使用AddMembers方法，但我不知道如何将职务指定为公共因素，而不是联系人姓名。您好。我收到一个错误91，对象变量或with block未在此行上设置：olRecipients.Add Oladlstantry.GetContact.Email1Address-我只有一个联系人，并且正确创建了DList，并且该联系人确实有Email1Address。有什么想法吗？我想可能是找到刚刚创建的数据列表，并将其视为联系人。寻找一种方法来检查联系人类型，如果它是一个数据列表，则跳过它。好的，我让它工作了，但问题是联系人没有添加到数据列表，只是他们的电子邮件地址。因此，当联系人使用新的电子邮件地址更新时，例如，当您单击“立即更新”时，此更改不会反映在数据列表中。我使用了“FileAs”属性，这似乎有效。谢谢你的帮助：）很有魅力！谢谢悉达思！

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