Как прикрепить лист Excel к электронной почте Outlook?

Question

Я пытаюсь исправить одну проблему, связанную с прикреплением файла.

У меня есть ТАБЛИЦА со списком людей и их именами, а также столбец условий (Y / N).

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

Я хочу отправлять электронные письма всем людям в ТАБЛИЦЕ, чье имя совпадает с уникальными значениями (имя) в одном из столбцов на листе 1.

Поэтому я хочу что-то, что просматривает столбец на листе 1 и, возможно, изменяет Условие на Y в ТАБЛИЦЕ для всех уникальных имен, найденных в этом столбце на Листе 1. (Я могу ФИЛЬТРОВАТЬ свою ТАБЛИЦУ в POWER QUERY, чтобы показать только строки с Условием «Y»).

Когда появляется одно сообщение (все люди в поле «Кому»), я хочу, чтобы к сообщению были прикреплены лист 1 или лист 2.

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

Код для прикрепления листа 1 (не работа)

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

Я хочу добавить код, чтобы всплывающее окно электронной почты (со всеми необходимыми людьми в «Кому» и) с вложением.

Answer 1

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

Answer 2

Идея заключается в том, чтобы скопировать лист в новый файл и сохранить его во временной папке. Затем прикрепите его к своей электронной почте

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

Дайте мне знать, если это работает