如何用VBA向Outlook子文件夹中的通讯组发送邮件

我需要使用VBA向Outlook公共文件夹子目录内的通讯组发送邮件，文件夹路径为Public folder\All Public Folders\Subfolder\Subfolder2...。文件夹内存在多个通讯组（例如“月度ABC公司报告组”“周度指数组”），每组包含10名以上收件人，需为不同通讯组发送不同内容的邮件，但当前代码将通讯组识别为纯文本，请问如何正确访问这些通讯组？

现有代码 #

Sub Arix_comp()

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")

Dim EItem As Object
Set EItem = EApp.CreateItem(0)

Dim subject_arix As String
subject_arix = Range("A2")
  
'NAV and MTD's
Dim index As Double
index = Range("G2")

Dim indexARIX As String
indexARIX = Format(index, "#'##0.00")

'Date variable
Dim myDate As Date
Dim myDateFormatted As String
Dim Month As String

myDate = Range("E2")
myDateFormatted = Format(myDate, "dd mmmm yyyy")
Month = Format(myDate, "mmm")

Dim olApp As Outlook.Application
Dim olNamespace As Outlook.namespace
Dim olPublicFolder1, olPublicFolder2, olPublicFolder3, olPublicFolder4 As Outlook.folder
Dim olItems As Outlook.Items
Dim hf_team As Object
    
' Create an instance of Outlook
Set olApp = New Outlook.Application
    
' Get the MAPI namespace
Set olNamespace = olApp.GetNamespace("MAPI")

' Specify the full folder path to the public folder and its subfolder
' For example, Public Folders\All Public Folders\Subfolder1\Subfolder2
Set olPublicFolder1 = olNamespace.GetDefaultFolder(olPublicFoldersAllPublicFolders)
'Set olPublicFolder = olPublicFolder.Folders("All Public Folders")
Set olPublicFolder2 = olPublicFolder1.Folders("FERI Alternative Assets")
Set olPublicFolder3 = olPublicFolder2.Folders("Verteilerlisten")
Set olPublicFolder4 = olPublicFolder3.Folders("Reportinglist HF")
Dim dlistpath As String
dlistpath = "olPublicFoldersAllPublicFolders\olPublicFolder2\olPublicFolder3\olPublicFolder4"
' Get all items (distribution lists) in the subfolder
Set olItems = olPublicFolder4.Items
Set hf_team = olItems.Find("zzz HF Team")
       
Set EItem = EApp.CreateItem(0)
With EItem
    .Bcc = hf_team
    .Subject = "ARIX Composite Institutional USD net weekly estimate"
    .Body = "Dear Sir or Madam," & vbNewLine & vbNewLine & "The current estimated value as of " & Sheet1.Range("E2").Text & " of the above mentioned index is:" & _
      vbNewLine & vbNewLine & "Index(" & Month & ")" & vbTab & indexARIX & vbNewLine & "MTD(" & Month & ")" & vbTab & Sheet1.Range("H2").Text & _
      vbNewLine & "YTD(" & Month & ")" & vbTab & Sheet1.Range("I2").Text & vbNewLine & vbNewLine & "This e-mail is directed exclusively to investors " & _
      "who hold investments advised by or managed by FERI. It provides information about developments with respect to such investments. If this information is not relevant to you and if you do not want to receive this e-mail in future, please send a cancellation request to hfop@feri.de." & _
      "Your e-mail address will then be deleted from the distribution list." & vbNewLine & vbNewLine & "Kind Regards,"
    .Display
    '.Save
    'Round(Range("F2").Value, 2)
End With
      
' Release the Outlook objects
Set hf_team = Nothing
Set olItems = Nothing

Set olPublicFolder1 = Nothing
Set olPublicFolder2 = Nothing
Set olPublicFolder3 = Nothing
Set olPublicFolder4 = Nothing
Set olNamespace = Nothing
Set olApp = Nothing

End Sub

问题修复与正确实现方案 #

1. 核心问题：通讯组对象的正确使用 #

Outlook中的通讯组是DistListItem类型对象，不能直接赋值给邮件的Bcc/To/Cc属性（直接赋值会被转成纯文本），必须通过邮件的Recipients.Add方法添加，并指定收件人类型为通讯组。

2. 修正通讯组查找逻辑 #

原代码的Find方法语法错误，需使用Outlook的查询语法定位通讯组名称，示例：

Set hf_team = olItems.Find("[Name] = 'zzz HF Team'")

如果查找失败，可添加FindNext循环确保找到目标通讯组。

3. 合并重复的Outlook实例 #

原代码创建了两个独立的Outlook实例，会造成资源浪费，统一使用一个实例即可。

4. 修正语法错误 #

原代码中的&;是笔误，需改为&，否则会触发编译错误。

修正后的完整代码 #

Sub Arix_comp()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olPublicFolder1, olPublicFolder2, olPublicFolder3, olPublicFolder4 As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim hf_team As Outlook.DistListItem ' 明确声明为通讯组类型
    Dim EItem As Outlook.MailItem
    
    ' 创建唯一的Outlook实例
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' 定位公共文件夹路径
    Set olPublicFolder1 = olNamespace.GetDefaultFolder(olPublicFoldersAllPublicFolders)
    Set olPublicFolder2 = olPublicFolder1.Folders("FERI Alternative Assets")
    Set olPublicFolder3 = olPublicFolder2.Folders("Verteilerlisten")
    Set olPublicFolder4 = olPublicFolder3.Folders("Reportinglist HF")
    
    ' 查找目标通讯组
    Set olItems = olPublicFolder4.Items
    Set hf_team = olItems.Find("[Name] = 'zzz HF Team'")
    
    ' 检查是否找到通讯组
    If Not hf_team Is Nothing Then
        ' 创建新邮件
        Set EItem = olApp.CreateItem(olMailItem)
        
        ' 向Bcc添加通讯组，指定收件人类型为通讯组
        With EItem.Recipients.Add(hf_team.Name)
            .Type = olBCC
            .Resolve ' 解析通讯组
        End With
        
        ' 填充邮件内容
        Dim index As Double
        index = Range("G2")
        Dim indexARIX As String
        indexARIX = Format(index, "#'##0.00")
        
        Dim myDate As Date
        Dim Month As String
        myDate = Range("E2")
        Month = Format(myDate, "mmm")
        
        With EItem
            .Subject = "ARIX Composite Institutional USD net weekly estimate"
            .Body = "Dear Sir or Madam," & vbNewLine & vbNewLine & _
                    "The current estimated value as of " & Sheet1.Range("E2").Text & " of the above mentioned index is:" & _
                    vbNewLine & vbNewLine & _
                    "Index(" & Month & ")" & vbTab & indexARIX & vbNewLine & _
                    "MTD(" & Month & ")" & vbTab & Sheet1.Range("H2").Text & vbNewLine & _
                    "YTD(" & Month & ")" & vbTab & Sheet1.Range("I2").Text & vbNewLine & vbNewLine & _
                    "This e-mail is directed exclusively to investors who hold investments advised by or managed by FERI. " & _
                    "It provides information about developments with respect to such investments. If this information is not relevant to you and if you do not want to receive this e-mail in future, please send a cancellation request to hfop@feri.de." & _
                    "Your e-mail address will then be deleted from the distribution list." & vbNewLine & vbNewLine & _
                    "Kind Regards,"
            .Display
            '.Save ' 如需自动保存可取消注释
        End With
    Else
        MsgBox "未找到目标通讯组：zzz HF Team"
    End If
    
    ' 释放资源
    Set EItem = Nothing
    Set hf_team = Nothing
    Set olItems = Nothing
    Set olPublicFolder4 = Nothing
    Set olPublicFolder3 = Nothing
    Set olPublicFolder2 = Nothing
    Set olPublicFolder1 = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

额外说明 #

• 如果需要给多个通讯组发送不同邮件，可复制查找和创建邮件的逻辑，修改通讯组名称和邮件内容即可。
• 确保已在VBA编辑器中引用Microsoft Outlook XX.X Object Library（工具→引用），避免后期绑定的兼容性问题。

内容的提问来源于stack exchange，提问作者Farogat