使用VBA.Array发送邮件时，如何添加多个不同位置的收件人

要实现单个邮件发送给多个收件人（对应不同单元格的邮箱），你需要调整收件人地址的存储和读取逻辑，让每个范围对应的收件人可以包含多个单元格地址，合并后作为同一邮件的收件人。以下是具体修改步骤和完整代码：

修改要点 #

• 调整Recipients数组，允许每个元素用逗号分隔多个单元格地址（例如"A1,E63"）
• 添加辅助函数GetCombinedRecipients，将多个单元格的邮箱地址合并为Outlook支持的分号分隔格式
• 替换原代码中读取单个收件人的逻辑，改为调用辅助函数获取合并后的收件人字符串

修改后的完整代码 #

Option Explicit

Private WorksheetNames As Variant
Private ValueRanges As Variant
Private OldValues As Variant

Private Sub Workbook_Open()
    WorksheetNames = VBA.Array("Info", "Info")
    ValueRanges = VBA.Array("E16:E20", "E22:E25")
    OldValues = GetValues
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ComposeAndSendMails
End Sub

Private Sub ComposeAndSendMails()
    
    Const COPY_COLUMNS As String = "A:E"
    Const ROW_DELIMITER As String = vbLf
    Const COL_DELIMITER As String = " - "
    Dim cIndices(): cIndices = VBA.Array(1, 2, 3, 5) ' skip column 'D'
    ' 修改Recipients数组，每个元素可包含多个逗号分隔的单元格地址
    Dim Recipients(): Recipients = VBA.Array("E61", "A1,E63")
    
    Dim rLen As Long: rLen = Len(ROW_DELIMITER)
    Dim cLen As Long: cLen = Len(COL_DELIMITER)
    Dim cUpper As Long: cUpper = UBound(cIndices)
    
    Dim BaseName As String:
    With ThisWorkbook
        BaseName = Left(.Name, InStrRev(.Name, ".") - 1)
    End With
    
    Dim NewValues(): NewValues = GetValues
    If IsEmpty(NewValues) Then Exit Sub ' 修正原代码的GetValues重复调用问题
    
    Dim bData(), n As Long, r As Long, c As Long, eCount As Long
    Dim Body As String, Recipient As String
    
    For n = 0 To UBound(NewValues)
        If IsColumnDifferent(OldValues(n), NewValues(n)) Then
            With ThisWorkbook.Sheets(WorksheetNames(n))
                bData = .Range(ValueRanges(n)).EntireRow _
                    .Columns(COPY_COLUMNS).Value
                ' 调用辅助函数获取合并后的收件人字符串
                Recipient = GetCombinedRecipients(.Range, Recipients(n))
            End With
            For r = 1 To UBound(bData, 1)
                For c = 0 To cUpper
                    Body = Body & bData(r, cIndices(c)) & COL_DELIMITER
                Next c
                Body = Left(Body, Len(Body) - cLen)
                Body = Body & ROW_DELIMITER
            Next r
            Body = Left(Body, Len(Body) - rLen)
            SendMailSimple BaseName, Recipient, Body
            eCount = eCount + 1
            Body = ""
        End If
    Next n

    If eCount > 0 Then
        OldValues = NewValues
    End If
    
    MsgBox IIf(eCount = 0, "No", eCount) & " message" _
        & IIf(eCount = 1, "", "s") & " sent.", _
            IIf(eCount = 0, vbExclamation, vbInformation)

End Sub

Private Function GetValues() As Variant
    
    If IsEmpty(WorksheetNames) Then
        MsgBox "The initial information got lost!", vbExclamation
        Exit Function
    End If
 
    Dim UB As Long: UB = UBound(WorksheetNames)
    Dim Jag(): ReDim Jag(0 To UB)
    
    Dim n As Long
 
    For n = 0 To UB
        With ThisWorkbook.Sheets(WorksheetNames(n)).Range(ValueRanges(n))
            Jag(n) = .Value
        End With
    Next n
        
    GetValues = Jag
 
End Function

Function IsColumnDifferent( _
    ByVal OldData As Variant, _
    ByVal NewData As Variant, _
    Optional ByVal ColumnIndex As Long = 1) _
As Boolean
    Dim r As Long
    For r = LBound(OldData, 1) To UBound(OldData, 1)
        If CStr(OldData(r, ColumnIndex)) <> CStr(NewData(r, ColumnIndex)) Then
            IsColumnDifferent = True
            Exit For
        End If
    Next r
End Function

Sub SendMailSimple( _
         ByVal Subject As String, _
         ByVal Recipient As String, _
         ByVal Body As String)
    With CreateObject("Outlook.Application").CreateItem(0)
        .Subject = Subject
        .To = Recipient
        .Body = Body
        .Send
    End With
End Sub

' 新增辅助函数：合并多个单元格的邮箱地址为分号分隔的字符串
Private Function GetCombinedRecipients(ByVal wsRange As Range, ByVal addrStr As String) As String
    Dim addrs() As String
    Dim i As Long
    Dim result As String
    
    ' 拆分地址字符串为单个单元格地址
    addrs = Split(addrStr, ",")
    
    For i = LBound(addrs) To UBound(addrs)
        ' 读取每个单元格的邮箱，去除前后空格
        Dim email As String
        email = Trim(CStr(wsRange.Parent.Range(Trim(addrs(i))).Value))
        ' 如果邮箱不为空，添加到结果中，用分号分隔
        If email <> "" Then
            If result <> "" Then result = result & ";"
            result = result & email
        End If
    Next i
    
    GetCombinedRecipients = result
End Function

说明 #

1. Recipients数组修改：现在每个元素可以是单个地址（如"E61"）或多个逗号分隔的地址（如"A1,E63"）
2. GetCombinedRecipients函数：负责拆分地址字符串，读取每个单元格的邮箱，合并为Outlook支持的分号分隔格式，自动忽略空值和多余空格
3. 原代码小修正：将If IsEmpty(GetValues) Then Exit Sub改为If IsEmpty(NewValues) Then Exit Sub，避免重复调用GetValues函数

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