excel - 从过滤列表中将多个文件附加到 Outlook 电子邮件并循环

Question

关闭。这个问题需要debugging details .它目前不接受答案。












编辑问题以包含 desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem .这将帮助其他人回答问题。


4年前关闭。







Improve this question




我有一个客户列表及其发票数据(一个客户可能有一行或多行数据)。我已经从多个代码中组装了一个宏脚本来过滤掉客户(基于电子邮件地址)并向他们发送一封催款信以及他们的帐户对帐单。

该代码在创建电子邮件时运行良好，但我无法附上第 2 列(在 TempoWB 工作簿中)中列出的发票副本。

我认为问题在于 Loop代码从 Do while 跳转直接到.HTMLBody .它跳过以前的代码来搜索和附加文件。我该如何解决？

这里是 Zip file包含所有必需的数据和文件。如果你想试一试。只需将“重命名”发票文件夹复制到 C:\Invoices。

(出于合规原因，客户名称和其他数据已被更改)

    Option Explicit

    Sub Dunning_3_Populate_Emails_TempWB()

     Application.ScreenUpdating = False

    'This code populates emails to outlook as per the Credit analysts.

        Dim OutApp As Object
        Dim OutMail As Object
        Dim rng As Range
        Dim Ash As Worksheet
        Dim Cws As Worksheet
        Dim Rcount As Long
        Dim Rnum As Long
        Dim name_rg As Range
        Dim name As String
        Dim Subj As String
        Dim irow As Integer
        Dim dpath As String
        Dim pfile As String
        Dim strbody As String
        Dim TempoWB As Workbook

     'Folder location for Invoice copies

        dpath = "C:\Invoices\Renamed"

     'Column number to pick the invoices
        irow = 2

        Set OutApp = CreateObject("Outlook.Application")

         name = Ash.Cells(name_rg.Row, 16)
         Subj = Ash.Cells(name_rg.Row, 15)
        Else
         name = "email not found in Ash"
        End If
    ------------------------------------------------------------------------------
    'This portion has codes to filter the required data based on the unique email address

    -----------------------------------------------------------------------------


     'Create a new workbook with selected/ filtered data
        rng.Copy
        Set TempoWB = Workbooks.Add(1)
        With TempoWB.Sheets(1)
            .Cells(1).PasteSpecial
             Application.CutCopyMode = False
             On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
             Columns("O:Q").Select
             Selection.Delete Shift:=xlToLeft
             On Error GoTo 0

     'Location to save the temporary workbook
             Application.DisplayAlerts = False
             TempoWB.SaveAs Filename:="C:\Invoices\TempoWB.xlsx"
        End With


     'E-mail body for the dunning letters

        strbody = "Hello " & name & "," & "<br>" & "<br>" & _

                  "<b>Below is the summary of your account and attached are the invoices:</b>" & "<br>" & "<br>"


        On Error GoTo Cleanup

        On Error Resume Next

    With OutMail
        .Display
        .To = Cws.Cells(Rnum, 1).Value
        .Subject = subj

         Workbooks("TempoWB.xlsx").Activate
For irow = 2 To Lastrow

        .Attachments.Add ("C:\Dunning Temp\" & Cells(irow, 2).Value & ".pdf")

Next

        .HTMLBody = strbody & RangetoHTML(rng) & .HTMLBody
        .Send
    End With

    On Error GoTo 0

    Set OutMail = Nothing
    End If

 'Close TempoWB
    Application.DisplayAlerts = False
    Workbooks("TempoWB.xlsx").Close SaveChanges:=False
    On Error Resume Next

 'Close AutoFilter
    Ash.AutoFilterMode = False


    Next Rnum

    End If

    End Sub

Answer 1

我最初对行计数器的怀疑是完全错误的。问题原来是几个小错误，只是导致代码在它永远找不到的地方寻找附件。

你应该知道的两件事:

1)当前您问题中的代码感觉不对，所以我将其扔掉并使用您最初发布的版本。

2)您需要更新路径/目录字符串并清除我所做的一些评论 block 。没什么太难的。

    Option Explicit                                                     'PO - Option Explicit, use it !

Sub Dunning_3_Populate_Emails()


 Dim test1 As Long, test2 As Long
 test1 = Timer
 Application.ScreenUpdating = False

'This code populates emails to outlook.

    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim SigString As String
    Dim Signature As String
    Dim name_rg As Range
    Dim name As String
    Dim Subj As String
    Dim irow As Integer
    Dim dpath As String
    Dim pfile As String
    Dim strbody As String


    dpath = Environ("appdata") & "\VBA\Stack Overflow\Attachments"      'PO - my environment only, delete
    '    dpath = "C:\Invoices\Renamed"                                  'PO - original code, use if it is correct or modify


    irow = 2

    'looping through all the files and sending an mail

    Set OutApp = CreateObject("Outlook.Application")


    'C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures           'PO - not my edit, guessing it is here for reference


'----------------------------------------------------------------
'PO - blocked this off because it wasn't related to the problem
'     should be perfectly ok to unblock
'----------------------------------------------------------------
'    SigString = Environ("appdata") & _
'                "\Microsoft\Signatures\My Signature.htm"
'
'    If Dir(SigString) <> "" Then
'       Signature = GetBoiler(SigString)
'    Else
'        Signature = ""
'    End If
'
'    On Error Resume Next
'
'    With Application
'        .EnableEvents = False
'        .ScreenUpdating = False
'    End With
'----------------------------------------------------------------


    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:Q" & Ash.Rows.Count)
    FieldNum = 17    'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

    Set OutMail = OutApp.CreateItem(0)

    ' ~ Search email address from Cws into Ash ~
    Set name_rg = Ash.Columns(17).Find(Cws.Cells(Rnum, 1))

    If Not name_rg Is Nothing Then

     name = Ash.Cells(name_rg.Row, 16)

     Subj = Ash.Cells(name_rg.Row, 15)

    Else
     name = "email not found in Ash"
    End If


    Set name_rg = Nothing

    strbody = "Hello " & name & "," & "<br>" & "<br>" & _
              "Hope you are fine!" & "<br>" & "<br>" & _
              "I am writing to share the list of open invoice(s) on your account with <b>Keysight Technologies Inc.</b>" & "<br>" & "<br>" & _
              "Please refer to th account statement below and let me know if you show any discrepancy on any of the open invoice(s), so that the required help can be arranged asap to get that resolved." & "<br>" & "<br>" & _
              "Also, if the invoice(s) has been paid already, kindly share the payment details" & "<br>" & "<br>" & _
              "<mark><i>** Please let me know if you have not recieved invoice copy so that I can arrange the invoice copy for you.</i></mark>" & "<br>" & "<br>" & _
              "<b>Below is the summary of your account:</b>" & "<br>" & "<br>"


    On Error GoTo Cleanup


    On Error Resume Next

    With OutMail
        .To = Cws.Cells(Rnum, 1).Value
        .Subject = Subj

'----------------------------------------------------------------
'PO - ranges and objects should be qualified to avoid bugs
'     It is very likely Cells() was reading from the last active sheet (Cws)
'----------------------------------------------------------------

        'Do While Cells(irow, 2) <> Empty                         'PO - unqualified, dangerous
         Do While Ash.Cells(irow, 2) <> Empty

             'pikcing up file name from column B
             'pfile = Dir(dpath & "\*" & Cells(irow, 2) & "*")     'PO - unqualified, dangerous
             pfile = Dir(dpath & "\*" & Ash.Cells(irow, 2) & "*")
             'checking for file exist in a folder and if its a pdf file

             'If pfile <> "" And Right(pfile, 2) = "pdf" Then      'PO - a 2 letter string cannot equal a 3 letter string
             If pfile <> "" And Right(pfile, 2) = "xt" Then        'PO - be sure to modify this
            .Attachments.Add (dpath & "\" & pfile)
             End If

             'go to next file listed on the C column
             irow = irow + 1

         Loop

        .HTMLBody = strbody & RangetoHTML(rng) & "<br>" & Signature
        .Send
    End With


'   Set ws = Nothing                                                'PO - "ws" is undefied, probably "Cws"

    On Error GoTo 0

    Set OutMail = Nothing
        End If
            'Close AutoFilter
            Ash.AutoFilterMode = False
    Next Rnum
    End If


Cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    test2 = Timer
    MsgBox "All the Collection Letters have been sent and it took only " & Format((test2 - test1) / 86400, "hh:mm:ss") & " Seconds."

End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

'    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"           'PO forward slash is wrong syntax
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        Columns("O:Q").Select
        Selection.Delete Shift:=xlToLeft
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         FileName:=TempFile, _
         Sheet:=TempWB.Sheets(1).name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

最后，嵌套的 while 循环是您开始陷入循环的原因。减少你的代码来说明这一点，它看起来像这样:

Do While Cells(irow, 2) <> Empty
   Do While Cells(irow, 2) = Empty
   Loop
Loop

这两个条件几乎总是会满足，因此如果单元格为空，您将卡在内部循环中，如果单元格已填充，您将卡在外部循环中。