求助：在VBA邮件代码中添加CC收件人及多附件循环功能

我帮你调整了VBA代码，现在可以实现读取抄送收件人，并且能将单元格内多个文件名对应的附件全部添加到邮件中。以下是完整的修改后代码：

Option Explicit

Public Sub ProcessFiles()
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
    
    Dim rowCount As Integer, i As Integer
    Dim emailTo As String, emailCC As String
    Dim fileNamesStr As String, fileNameArr As Variant
    Dim filePath As String
    
    With Worksheets("Email List")
        rowCount = Application.WorksheetFunction.CountA(.Columns(1))
        '从第2行开始遍历数据行
        For i = 2 To rowCount
            emailTo = .Cells(i, 1).Value
            emailCC = .Cells(i, 2).Value
            fileNamesStr = .Cells(i, 3).Value
            
            '拆分多个文件名（按逗号分隔）
            fileNameArr = Split(Trim(fileNamesStr), ",")
            
            '创建新邮件
            Dim OutMail As Object
            Set OutMail = OutApp.CreateItem(0)
            
            On Error Resume Next
            Application.ScreenUpdating = False
            
            With OutMail
                .To = emailTo
                .CC = emailCC
                .Subject = "Sales Forecast - " & Format(Now, "dd/mmm/yyyy")
                .Body = "Dear Sir/Madam," & vbNewLine _
                        & vbNewLine _
                        & "Please find the attached files of Sales History of Last 6 Months" & vbNewLine _
                        & vbNewLine _
                        & "Requesting you to kindly provide the Retail Forecast for June 2018 at earliest by 27th of this month" & vbNewLine _
                        & vbNewLine _
                        & "Please feel free to contact if you have any questions regarding the same." & vbNewLine _
                        & vbNewLine _
                        & "Rgds"
                
                '循环添加每个附件
                Dim j As Integer
                For j = LBound(fileNameArr) To UBound(fileNameArr)
                    filePath = getFileName(Trim(fileNameArr(j)))
                    '检查文件是否存在
                    If Len(Dir(filePath)) > 0 Then
                        .Attachments.Add filePath
                    Else
                        MsgBox "文件 " & filePath & " 不存在，已跳过该附件", vbExclamation
                    End If
                Next j
                
                .Display '如果需要直接发送，替换为.Send
            End With
            
            On Error GoTo 0
            Set OutMail = Nothing
            Application.ScreenUpdating = True
        Next i
    End With
    
    Set OutApp = Nothing
    MsgBox "邮件处理完成", vbInformation
End Sub

Public Function getFileName(filebasename As String) As String
    Dim folderPath As String, fileExtension As String
    
    folderPath = Range("Settings!B1").Value
    fileExtension = Range("Settings!B2").Value
    
    '确保扩展名以.开头
    If Left(fileExtension, 1) <> "." Then
        fileExtension = "." & fileExtension
    End If
    '确保文件夹路径以\结尾
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If
    
    '生成完整文件路径
    getFileName = folderPath & filebasename & fileExtension
End Function

关键修改说明： #

• 新增抄送收件人支持：在遍历数据行时读取B列的抄送地址，直接赋值给邮件的.CC属性
• 多附件处理逻辑：使用Split函数将C列的文件名列表拆分为数组，循环每个文件名生成完整路径，检查文件存在后添加到附件
• 优化Outlook对象创建：将邮件创建逻辑整合到ProcessFiles中，避免重复创建Outlook应用实例，提升效率
• 修正函数逻辑：移除getFileName中错误的单元格引用，专注于生成单个文件的完整路径
• 增加错误提示：如果某个文件不存在，会弹出提示告知用户，避免静默失败

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