如何在Excel VBA中访问联系人组？

Question

我正在构建一个 Excel 插件，它将活动工作簿作为 Outlook 电子邮件模板中的附件发送到特定的联系人组。

我已经获得了前两部分，可以使用下面的代码，但我不确定如何将

.TO

字段设置为联系人组。

Public Sub Mail_Reports()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object 

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    On Error Resume Next

    Set OutApp = CreateObject("Outlook.Application")

    'Set this line to the path and file name of your template
    Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\moses\AppData\Roaming\Microsoft\Templates\test.oft")
    On Error Resume Next

    With OutMail
        '.TO field should be set to the contact group
        .BCC = ""
        .Attachments.Add ActiveWorkbook.FullName
        .HTMLBody = Replace(OutMail.HTMLBody, strOldPeriod, strNewPeriod)
        .Subject = Replace(OutMail.Subject, strOldPeriod, strNewPeriod)
        'To display the email leave as is;  to send the Email, change to .Send
        .Display    'or Send
    End With

    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

只需使用联系人组的名称（以前称为“通讯组列表”）。我刚刚按照 Ron de Bruin's 网站上的建议尝试过，它有效。

Answer 2

扩展已接受的答案以仅使用名称，确保联系人组名称不含糊。

例如，如果我有两个名为“我的列表”和“我的列表 2”的组。当我尝试手动发送电子邮件并且仅在“收件人”框中键入“我的列表”时，Outlook 会显示一个弹出窗口，询问要解析哪个列表。这有点像 Excel 中的自动填充建议。如果我输入“我的列表 2”，Outlook 将确切地知道我想要哪个列表。

同样，Outlook 在通过 VBA 尝试相同的操作时也会感到困惑，并且错误消息不是很清楚：“Outlook 无法识别一个或多个名称”。

我知道的最简单的解决方法是将“我的列表”的名称更改为“我的列表 1”或任何其他完全唯一的名称，其中没有其他列表共享该确切的基本名称。

Answer 3

为了解析收件人的电子邮件地址或姓名（以便它们不只显示纯文本），您可以执行以下操作。

With OutMail
    '.TO field should be set to the contact group
    .BCC = ""
    .Attachments.Add ActiveWorkbook.FullName
    .HTMLBody = Replace(OutMail.HTMLBody, strOldPeriod, strNewPeriod)
    .Subject = Replace(OutMail.Subject, strOldPeriod, strNewPeriod)
    'To display the email leave as is;  to send the Email, change to .Send
    .Display    'or Send
    If Not .Recipients.ResolveAll Then
        For Each Recipient In .Recipients
            If Not Recipient.Resolved Then
                MsgBox Recipient.Name & " could not be resolved"
            End If
        Next 
    End If
End With

Answer 4

这是最好的方法：

  Sub runcode()
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Call distList
    
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Sub distList()
    
        
    Dim app As Outlook.Application
    Set app = New Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Set objNamespace = app.GetNamespace("MAPI")

    Dim re As Outlook.Recipient
    Dim dl As Outlook.ExchangeDistributionList
    Dim currentColumn As Integer
    
    ' Clear existing data in columns B, C, and D
    Range("B2:E" & Rows.Count).Clear

    ' Loop through columns B and D
    Dim e As Variant
    For Each e In Array(2, 4)
        Set re = objNamespace.CreateRecipient(Cells(1, e))
        If re.Resolve() Then
            Set dl = re.AddressEntry.GetExchangeDistributionList
            If Not dl Is Nothing Then
                For i = 1 To dl.Members.Count
                    ' Put the member's name in columns B and D
                    Cells(i + 1, e) = dl.Members(i).Name
                Next i
                
                ' Call a generic function to split names based on the current column
                SplitNames e
            End If
        End If
    Next e
    

End Sub

Sub SplitNames(ByVal colIndex As Variant)
    
    Dim lastRow As Long
    Dim i As Long
    
    ' Find the last row in the specified column
    lastRow = Cells(Rows.Count, colIndex).End(xlUp).Row
    
    ' Loop through each row in the specified column
    For i = 2 To lastRow
        ' Get the full name from the specified column
        Dim fullName As String
        fullName = Cells(i, colIndex).Value
        
        ' Split the full name into first name and last name
        Dim nameParts() As String
        nameParts = Split(fullName, " ")
        
        ' Check if there are at least two parts (first name and last name)
        If UBound(nameParts) >= 1 Then
            ' Get the first initial, period, space, and last name
            Dim resultName As String
            resultName = Left(nameParts(0), 1) & ". " & nameParts(UBound(nameParts))
            
            ' Put the result in the next column (e.g., if colIndex is 2, put in column C)
            Cells(i, colIndex + 1).Value = resultName
        End If
    Next i
    
End Sub