vba 将联系人添加到 Outlook 通讯组列表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10637729/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Add contacts to Outlook Distribution List
提问by tonyyeb
I have 1000+ contacts each with a selection of common job titles. I'd like to programmatically add each job title group (e.g. all the contacts with the job title 'Managing Director') into a Distribution List (e.g. 'Managing Directors').
我有 1000 多个联系人，每个联系人都有一些常见的职位。我想以编程方式将每个职位组（例如所有职位名称为“总经理”的联系人）添加到分发列表（例如“总经理”）中。
回答by Siddharth Rout
Ok here is an example for only the default Contacts folder. Similarly, you have to go to every folder where a DL might exist, starting with the default Contacts folder to check if the Dist List exists before creating it.
好的，这里仅是默认联系人文件夹的示例。同样，您必须转到可能存在 DL 的每个文件夹，从默认的联系人文件夹开始，在创建之前检查 Dist 列表是否存在。
TRIED AND TESTED (IN OUTLOOK VBA)
久经考验（在 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
