如何将Excel工作表附加到Outlook电子邮件? [英] 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)  

我想向表中名称与表单1中一列中的唯一值(名称)相匹配的所有人发送电子邮件.

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.

因此，我希望在表1中查找该列，并可能将表1中该列中找到的所有唯一名称的条件更改为TABLE中的Y.(我可以在POWER QUERY中过滤我的表以仅显示条件为"Y"的行).

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").

当SINGLE电子邮件弹出时(收件人"中的所有人)，我希望将工作表1或工作表2附加到电子邮件中.

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

附加工作表1的代码(无效)

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.

推荐答案

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

这篇关于如何将Excel工作表附加到Outlook电子邮件?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！