将relevent Excel文件附加到自动电子邮件

最后发布: 2017-05-24 15:12:40


问题

我已经编写了代码,可以按制造商名称将数据导出到为制造商命名的新书中。

现在,我调整了一个电子邮件宏以自动向制造商发送电子邮件。

我希望它可以自动附加我的文档中的文件

这是我所拥有的,但不附带任何内容。

Sub BacklogEmail()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

Set tb = ActiveSheet.ListObjects("Table10")


For i = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
    For X = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(X) Then GoTo goToNext
    Next X
        On Error GoTo 0
        subjectLine = "Obsolescence Report for Manufacturer(s)  "
        ReDim Preserve myArray1(1 To nameCounter)
        myArray1(nameCounter) = emAddress
        nameCounter = nameCounter + 1
        lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set C = .Find(emAddress, LookIn:=xlValues)
                If Not C Is Nothing Then
                    firstaddress = C.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                    Do
                        Nrow = C.Row - 1
                        If lineCounter = 1 Then
                            subjectLine = subjectLine & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index)
                            lineCounter = lineCounter + 1
                           ' bodyline = "Manufacturer " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        Else:
                            subjectLine = subjectLine
                            'bodyline = bodyline & vbNewLine & "Manufacturer " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        End If

                        Set C = .FindNext(C)
                    Loop While Not C Is Nothing And C.Address <> firstaddress
                End If
                        Run SendMailFunction(emAddress, subjectLine, bodyline)
'                        Debug.Print vbNewLine
'                        Debug.Print emAddress
'                        Debug.Print "Subject: " & subjectLine
'                        Debug.Print "Body:" & vbNewLine; bodyline
            End With
goToNext:
Next i
Set C = Nothing
End Sub




Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")

           ReDim Preserve myArray1(1 To nameCounter)
           myArray1(nameCounter) = emAddress
           nameCounter = nameCounter + 1
           lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set C = .Find(emAddress, LookIn:=xlValues)
               If Not C Is Nothing Then
                    firstaddress = C.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                        Nrow = C.Row - 1
                      If lineCounter = 1 Then
                      Set OutMail = OutApp.CreateItem(0)
       On Error Resume Next
        With OutMail

            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, attached is an excel file that we require you to complete. " & _
                    "This is required by as we must know when parts are going to become obsolete. " & _
                    "We appriciate your contribution to keeping our databases current. " & _
                    "Thank you for your timely response."
                            .Attachments.Add "U:\\\\" & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ".xlsx"
                            lineCounter = lineCounter + 1

           .Display


     On Error GoTo 0
        Set OutMail = Nothing


End With
End If
End If
End With
End Function
excel vba excel-vba outlook outlook-vba
回答

将您的attach.add行更改为:

Debug.Print "C:\users\dmack\my documents\" & tb.DataBodyRange.Cells(Nrow, tb, ListColumns("Manufacturer Name").Index)

并且如果您开始在即时窗口中看到正确的完整文件路径\\文件名,请再次将其更改为:

.Attachments.Add "C:\users\dmack\my documents\" & tb.DataBodyRange.Cells(Nrow, tb, ListColumns("Manufacturer Name").Index)


回答

这是完全有效的答案,可以遍历电子邮件列表并发送所需的excel文件。 它将在5分钟内发送200封电子邮件。 正确。 为所有帮助加油!

Sub BacklogEmail()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

Set tb = ActiveSheet.ListObjects("Table10")


For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
    For X = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(X) Then GoTo goToNext
    Next X
        On Error GoTo 0
        subjectLine = "Update Required For on Order(s) # "
        ReDim Preserve myArray1(1 To nameCounter)
        myArray1(nameCounter) = emAddress
        nameCounter = nameCounter + 1
        lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set C = .Find(emAddress, LookIn:=xlValues)
                If Not C Is Nothing Then
                    firstaddress = C.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                    Do
                        Nrow = C.Row - 1
                        If lineCounter = 1 Then
                            subjectLine = subjectLine & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index)
                            lineCounter = lineCounter + 1
                            bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        Else:
                            subjectLine = subjectLine
                            bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ",  Manufacturer Item Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Item Number").Index)
                        End If

                        Set C = .FindNext(C)
                        Debug.Print vbNewLine
                        Debug.Print emAddress
                        Debug.Print "Subject: " & subjectLine
                        Debug.Print "Body:" & vbNewLine; bodyline
                    Loop While Not C Is Nothing And C.Address <> firstaddress
                End If

                        Run SendMailFunction(emAddress, subjectLine, bodyline)


            End With
goToNext:
Next I
Set C = Nothing
End Sub


Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")

           ReDim Preserve myArray1(1 To nameCounter)
          myArray1(nameCounter) = emAddress
           nameCounter = nameCounter + 1
           lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set C = .Find(emAddress, LookIn:=xlValues)
               If Not C Is Nothing Then
                    firstaddress = C.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                        Nrow = C.Row - 1
                      If lineCounter = 1 Then

      Set OutMail = OutApp.CreateItem(0)
       On Error Resume Next
        With OutMail

            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, attached is an excel file that we require you to complete. " & _
                    "This is required by as we must know when parts are going to become obsolete. " & DNL & _
                    "We appriciate your contribution to keeping our databases current. " & DNL & _
                    "Thank you for your timely response."
            .Attachments.Add ":\\\\\" & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Manufacturer Name").Index) & ".xlsx"
                            lineCounter = lineCounter + 1

           .Display

      End With
     On Error GoTo 0
        Set OutMail = Nothing


End If
End If
End With
End Function