How to attach an Excel sheet to an Outlook email?

问题

I'm trying to fix one issue which is attaching a file.

I have a TABLE with list of people and their names and a condition(Y/N) column.

Column 1(Name)          Column 2(Email)            Column 3 (Condition Y/N)  

I want to send emails to all people in the TABLE whose name matches with the unique values (name) in one of the columns in Sheet 1.

So I want something that looks up the column in Sheet 1 and maybe changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition "Y").

When the SINGLE email pops up (with the all people in the "To",) I want Sheet 1 or Sheet 2 to be attached to the email.

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Adapted by Ricardo Diaz ricardodiaz.co

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table6").ListObject ' -> Set the table's name

    On Error GoTo cleanup

    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And _
          LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next

    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please comply with the transfers in the attached file. " & _
                "Look up for your store and process asap."

        'You can add files also like this
        '.Attachments.Add ("C:\test.txt") ' -> Adjust this path

        .Display     ' -> Or use Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Code to Attach sheet 1 (doesn't work)

file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"

Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
  "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import

I want to add code so my email pops up (with all required people in "To" and) with the attachment.

回答1:

The idea here is to copy the sheet to a new file and save it in you temp folder. Then attach it to your email

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
    ' Adapted by Ricardo Diaz ricardodiaz.co
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim newBook As Workbook
    Dim newBookName As String

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table1").ListObject

    On Error GoTo Cleanup

    ' Save current file to temp folder (delete first if exists)
    ThisWorkbook.Worksheets("Sheet1").Copy
    Set newBook = ActiveWorkbook
    newBookName = "AttachedSheet.xlsx"
    On Error Resume Next
    Kill Environ("temp") & newBookName
    On Error GoTo 0
    Application.DisplayAlerts = False
    newBook.SaveAs Environ("temp") & newBookName
    Application.DisplayAlerts = True

    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please contact us to discuss bringing " & _
                "your account up to date"

        'You can add files also like this
        .Attachments.Add newBook.FullName ' -> Adjust this path

        .Display ' -> Or use Display
    End With

    Set OutMail = Nothing

Cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Let me know if it works

回答2:

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration

Public Sub AttachFileToEmail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Dim strDir As String
    Dim file_name_import As String
    Dim fName As String

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    ' Excel details not recreated, not needed for this question

    file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
    file_name_import = file_name_import & " - File 1.xlsx"

    ' Subscript out of range error would be bypassed due to poor error handling
    'Worksheets("Sheet 1").Copy
    Worksheets("Sheet1").Copy

    ' Trailing backslash error would be bypassed due to poor error handling
    'ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"

    strDir = "C:\Folder 1\Folder 2\Folder 3\Folder 4\"
    Debug.Print strDir

    ' Backslash already at end of strDir
    fName = strDir & "File 1" & file_name_import
    Debug.Print fName

    ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)

    ' Do not use On Error Resume Next without a specific reason for bypassing errors
    ' Instead fix the errors now that you can see them

    With OutMail

        ' Excel details not recreated, not needed for this question

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please comply with the transfers in the attached file. " & _
                "Look up for your store and process asap."

        .Attachments.Add fName

        .Display

    End With

    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub

来源：https://stackoverflow.com/questions/59903072/how-to-attach-an-excel-sheet-to-an-outlook-email