使用变量调用.Attachments.Add无法添加邮件附件的问题排查

我看了你的代码和描述，最可能的问题出在路径字符串的拼接错误上，另外还有几个细节需要检查，咱们一步步来：

1. 路径拼接的致命错误：缺少反斜杠 #

你看这段代码：

path1 = "C:\Users" & id & "\Desktop" & title1 & ".xlsx"
path2 = "C:\Users" & id & "\Desktop" & title2 & ".xlsx"

这里有两处反斜杠缺失：

• C:\Users 后面应该加 \，不然会变成 C:\Usersid（比如id是john的话，路径开头就成了C:\Usersjohn，这显然不是正确的用户目录）
• \Desktop 后面也应该加 \，不然文件名会直接跟在Desktop后面，变成\Desktopfilename.xlsx，而不是\Desktop\filename.xlsx

正确的写法应该是：

path1 = "C:\Users\" & id & "\Desktop\" & title1 & ".xlsx"
path2 = "C:\Users\" & id & "\Desktop\" & title2 & ".xlsx"

这应该是导致附件找不到的核心原因——你用MsgBox看到的路径可能因为视觉错觉看起来正确，但实际拼接出来的路径完全不合法，而直接写死的路径是有正确反斜杠的，所以能正常添加。

2. 其他需要排查的点 #

如果修正反斜杠后还是不行，试试这些方法：

去掉On Error Resume Next，暴露错误 #

你的代码里有On Error Resume Next，这会掩盖所有错误信息，哪怕附件路径不存在、文件被锁定，你也看不到任何提示。先把这行注释掉，运行代码，看弹出的错误提示是什么，能直接帮你定位问题。

验证文件是否真的存在 #

在添加附件前，用Dir函数检查文件是否存在：

' 检查path1是否存在
If Dir(path1) = "" Then
    MsgBox "找不到文件：" & path1, vbCritical
    Exit Sub
End If
' 检查path2是否存在
If Dir(path2) = "" Then
    MsgBox "找不到文件：" & path2, vbCritical
    Exit Sub
End If

如果弹出提示，说明路径还是有问题，或者文件被移动/删除了。

清理变量中的隐形字符 #

有时候id或者title1/title2参数里可能带有空格、换行符这类隐形字符，导致路径看起来正确但实际无效。给变量加上Trim处理：

id = LCase(Trim(Workbooks("Supplier_Automation.xlsm").Sheets("Home").Range("C3").Value))
title1 = Trim(title1)
title2 = Trim(title2)

检查文件是否被锁定 #

如果文件正在被Excel或其他程序打开，Outlook可能无法读取它作为附件。确保添加附件前，目标文件已经关闭。

修正后的代码片段 #

把这些修正点整合后，相关部分的代码大概是这样：

Sub Mail_Workbook_Comb1(ByVal title1 As String, ByVal title2 As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim id As String
    Dim path1 As String
    Dim path2 As String
    Dim rnge As Range
    Dim sht As Excel.Worksheet
    Dim wdoc As Word.Document
    Dim distroRnge As Range
    
    ' 清理变量中的隐形字符
    id = LCase(Trim(Workbooks("Supplier_Automation.xlsm").Sheets("Home").Range("C3").Value))
    title1 = Trim(title1)
    title2 = Trim(title2)
    
    ' 修正路径拼接的反斜杠
    path1 = "C:\Users\" & id & "\Desktop\" & title1 & ".xlsx"
    path2 = "C:\Users\" & id & "\Desktop\" & title2 & ".xlsx"
    
    ' 检查文件是否存在
    If Dir(path1) = "" Then
        MsgBox "找不到文件：" & path1, vbCritical
        Exit Sub
    End If
    If Dir(path2) = "" Then
        MsgBox "找不到文件：" & path2, vbCritical
        Exit Sub
    End If
    
    MsgBox path1
    MsgBox path2
    
    Set distroRnge = Workbooks("Supplier_Automation.xlsm").Sheets("Distros").Range("A29")
    Set sht = Workbooks("Supplier_Automation.xlsm").Sheets("Email Template")
    Set rnge = sht.Range("B1:B19")
    rnge.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set wdoc = OutMail.GetInspector.WordEditor
    
    ' 暂时注释掉On Error Resume Next，方便排查错误
    ' On Error Resume Next
    
    With OutMail
        .To = "myname@email.com" ' 这里要加引号，原代码漏了
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = ""
        .Attachments.Add path1
        .Attachments.Add path2
        wdoc.Range.PasteAndFormat Type:=wdChartPicture
        With wdoc
            .InlineShapes(1).Height = 345
        End With
        .Display 'or use .Send
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    ' On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

另外注意原代码里.To = myname@email.com这里少了引号，应该改成.To = "myname@email.com"，不然也会报错。

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