Excel宏发送邮件时无法附加PowerPoint演示文稿问题求助

一、先排查附件路径相关问题 #

• 必须使用完整绝对路径：D到M列中填写的文件路径得是全路径，比如C:\桌面\演示文稿.pptx，不能只写文件名或相对路径，否则Dir函数无法定位到文件。
• 检查路径中的空格与特殊字符：如果路径包含空格（比如C:\我的文件夹\演示文稿.pptx），要确保单元格里的路径没有输入错误，也没有隐形空格，建议直接复制粘贴文件的完整路径到单元格中。
• 添加调试弹窗验证路径：可以在代码的附件循环里加一句MsgBox "当前检查路径：" & FileCell.Value，运行时会弹出每个待附加的路径，确认是否为目标文件的正确路径。

二、修正代码中的范围引用错误（核心问题） #

原代码里Set rng = sh.Cells(cell.Row, 1).Range("D1:M1")这行逻辑错误：它不是指向当前收件人行的D到M列，而是固定指向工作表的D1到M1单元格！也就是说无论处理哪一行的收件人，都只会读取D1-M1的路径，这大概率是附件未添加的主要原因。

将这行代码替换为：

Set rng = sh.Range(sh.Cells(cell.Row, "D"), sh.Cells(cell.Row, "M"))

三、优化附件添加逻辑 #

• 移除Dir函数判断：Dir函数无法识别正在打开的文件（如果你的PPT处于打开状态，Dir会返回空值），直接使用.Attachments.Add配合错误处理更可靠。
• 添加错误提示：如果某个路径无效，弹窗提示具体错误信息，方便快速排查问题。

修正后的完整代码 #

Sub sendEmailsToMultiplePersonsWithMultipleAttachments()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

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

    Set sh = Sheets("Hoja1")
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        ' 修正范围引用：指向当前行的D到M列
        Set rng = sh.Range(sh.Cells(cell.Row, "D"), sh.Cells(cell.Row, "M"))
        
        If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .To = sh.Cells(cell.Row, 1).Value
                .CC = sh.Cells(cell.Row, 2).Value
                .Subject = "Boarder Logistics Corporations CHILE"
                .Body = sh.Cells(cell.Row, 3).Value
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell.Value) <> "" Then
                        On Error Resume Next
                        .Attachments.Add FileCell.Value
                        If Err.Number <> 0 Then
                            MsgBox "添加附件失败：" & FileCell.Value & vbCrLf & "错误原因：" & Err.Description
                            Err.Clear
                        End If
                        On Error GoTo 0
                    End If
                Next FileCell
                '.Send
                .Display
            End With
            
            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

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