用户选择时将文档附加到电子邮件

Question

我被要求制作一个程序，选择要发送到的电子邮件范围，然后抄送到一个范围，然后将用户选择的文档附加到生成的电子邮件中。

我从各种教程中一起科学怪人。
它选择电子邮件地址和抄送，从文本框中拉出正文段落，并包含所需的主题行。
我可以选择文件，但生成的电子邮件没有附件。为什么所选文件没有附加到生成的电子邮件中？其他一切正常。

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 Myfile As FileDialog
    Dim xFileDlg As FileDialog
    Dim xSelItem As Variant

    Set Myfile = Application.FileDialog(msoFileDialogFilePicker)
    Dim FileAddress As String
  
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the addresses list:", "Please select", xTxt, , , , , 8)
    On Error GoTo 0
    If xRg Is Nothing Then Exit Sub
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)
    
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    
    xTxt = ActiveWindow.RangeSelection.Address
    Set xCCRg = Application.InputBox("Please select the CC list:", "Please select", xTxt, , , , , 8)
    If xCCRg Is Nothing Then Exit Sub
    For Each xCC In xCCRg
        If xCC.Value Like "*@*" Then
            If xCCAddr = "" Then
                xCCAddr = xCC.Value
            Else
                xCCAddr = xCCAddr & ";" & xCC.Value
            End If
        End If
    Next
    
    With xMailItem
        xFileDlg.InitialFileName = "initial file path goes here but I have removed it" 
        With Myfile
            .Filters.Clear
            .Title = "Please select a file to add"
            .Show
        End With
    
        .To = xEmailAddr
        .CC = xCCAddr
        .Subject = "This is a sample subject line" 
        .Body = ActiveSheet.TextBoxes(1).Text
        .AllowMultiSelect = True
        Set xMailItem = Application.ActiveInspector.CurrentItem

        For Each xSelItem In xFileDlg.SelectedItems
            xMailItem.Attachments.Add xSelItem
        Next

        FileAddress = .SelectedItems(1)
        .Attachments.Add = .SelectedItems(1)
        .Display
    End With
    Set xOutlook = Nothing
    Set xMailItem = Nothing
End Sub

Answer 1

线

.Attachments.Add = .SelectedItems(1)

错了。您是指以下内容吗？

.Attachments.Add .SelectedItems(1)

Answer 2

With

块为简单而分开，但不是必需的。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Sub EmailAttachmentRecipients2()

    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)
    
    xTxt = ActiveWindow.RangeSelection.Address
        
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the addresses list:", "Please select", xTxt, , , , , 8)
    On Error GoTo 0 ' Consider mandatory to closely follow On Error Resume Next
    
    If xRg Is Nothing Then Exit Sub
    
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)
    
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    
    xTxt = ActiveWindow.RangeSelection.Address
    Set xCCRg = Application.InputBox("Please select the CC list:", "Please select", xTxt, , , , , 8)
    If xCCRg Is Nothing Then Exit Sub
    For Each xCC In xCCRg
        If xCC.Value Like "*@*" Then
            If xCCAddr = "" Then
                xCCAddr = xCC.Value
            Else
                xCCAddr = xCCAddr & ";" & xCC.Value
            End If
        End If
    Next
    
    With xFileDlg
        .Filters.Clear
        .Title = "Please select a file to add"
        'xFileDlg.InitialFileName = "initial file path goes here but I have removed it"
        .AllowMultiSelect = True
        .Show
            
        For Each xSelItem In .SelectedItems
            xMailItem.Attachments.Add xSelItem
        Next
    End With
        
    With xMailItem
        .To = xEmailAddr
        .CC = xCCAddr
        .Subject = "This is a sample subject line"
        '.Body = ActiveSheet.TextBoxes(1).Text
        .Body = "Test"
        .Display
    End With
    
    Set xOutlook = Nothing
    Set xMailItem = Nothing
End Sub