VBA生成Outlook邮件时附件失效问题求助

核心问题点 #

• 文件对话框变量混用：你定义了Myfile和xFileDlg两个对话框对象，但实际用Myfile弹出选择窗口，却去遍历未初始化的xFileDlg.SelectedItems，导致附件添加逻辑完全没执行。
• 错误重置邮件对象：Set xMailItem = Application.ActiveInspector.CurrentItem这行在邮件还没显示时，ActiveInspector不存在，会把之前创建的邮件对象覆盖成空，后续所有操作都失效。
• 语法错误：.Attachments.Add = .SelectedItems(1)是错误写法，Add是方法，不能用赋值语法，正确格式是.Attachments.Add 文件路径。
• 属性放错位置：.AllowMultiSelect = True应该设置在文件对话框上，不是邮件对象上。

修复后的完整代码 #

Sub EmailAttachmentRecipients1()
    Dim xOutlook As Object
    Dim xMailItem As Object
    Dim xRg As Range
    Dim xCell As Range
    Dim xCC As Range
    Dim xEmailAddr As String
    Dim xCCAddr As String
    Dim xTxt As String
    Dim xCCRg As Range
    Dim xFileDlg As FileDialog
    Dim xSelItem As Variant

    ' 初始化文件选择对话框
    Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    With xFileDlg
        .Filters.Clear
        .Title = "请选择要添加的文件"
        .AllowMultiSelect = True ' 开启多选功能
        .InitialFileName = "初始文件路径" ' 可自行设置默认打开路径
    End With
  
    ' 选择收件人范围
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("请选择收件人地址列表:", "选择收件人", xTxt, , , , , 8)
    On Error GoTo 0
    If xRg Is Nothing Then Exit Sub

    ' 收集收件人地址
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            xEmailAddr = IIf(xEmailAddr = "", xCell.Value, xEmailAddr & ";" & xCell.Value)
        End If
    Next
    
    ' 选择抄送人范围
    xTxt = ActiveWindow.RangeSelection.Address
    Set xCCRg = Application.InputBox("请选择抄送人地址列表:", "选择抄送人", xTxt, , , , , 8)
    If xCCRg Is Nothing Then Exit Sub

    ' 收集抄送人地址
    For Each xCC In xCCRg
        If xCC.Value Like "*@*" Then
            xCCAddr = IIf(xCCAddr = "", xCC.Value, xCCAddr & ";" & xCC.Value)
        End If
    Next
    
    ' 创建Outlook邮件
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)

    ' 弹出文件选择框并添加附件
    If xFileDlg.Show = -1 Then ' 判断用户是否选择了文件
        With xMailItem
            .To = xEmailAddr
            .CC = xCCAddr
            .Subject = "这是示例主题"
            .Body = ActiveSheet.TextBoxes(1).Text
            
            ' 批量添加选中的附件
            For Each xSelItem In xFileDlg.SelectedItems
                .Attachments.Add xSelItem
            Next
            
            .Display ' 显示邮件
        End With
    End If

    ' 释放资源
    Set xOutlook = Nothing
    Set xMailItem = Nothing
    Set xFileDlg = Nothing
End Sub

修复说明 #

1. 合并冗余的对话框变量，只保留xFileDlg并正确配置参数，开启多选功能。
2. 删掉错误的邮件对象重置语句，避免覆盖已创建的邮件实例。
3. 把文件选择逻辑移到邮件创建之后，确保选中的文件能正确关联到邮件。
4. 用IIf简化收件人/抄送人地址的拼接，代码更简洁。
5. 增加用户选择判断，避免无文件时执行附件添加逻辑。

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