问题
I have a list of customers with their invoice data (one customer may have one or more than one rows of data). I have assembled a macro script from multiple codes to filter out the customer (basis on email address) and send them a dunning letter with their account statement.
The code is working fine with email creation, except I am not able to attach their invoice copies listed in column 2 (In TempoWB workbook).
I think the problem is with Loop The code is jumping from Do while directly to .HTMLBody.It's skipping the previous codes to search and attach files. How can I fix it?
Here is the Zip file with all required data and files. In case you want to give it a try. Just copy the 'Renamed' invoice folder to C:\Invoices.
(customer names and other data has been altered for compliance reason)
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
回答1:
My initial suspicion of the row counter was just flat wrong. The problem turned out to be several small errors that simply caused the code to look for the attachment in places it could never find it.
Two things you should know:
1) The code currently in your question didn't feel right so I tossed it and went with the version you originally posted.
2) You need to update the path/directory strings and clear some comment blocks I've made. Nothing too difficult.
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
And lastly, the nested while loops are the reason you started getting stuck in a loop. Reducing your code to illustrate the point, it looked something ike this:
Do While Cells(irow, 2) <> Empty
Do While Cells(irow, 2) = Empty
Loop
Loop
Both conditions will almost always be met so you get stuck on the inside loop if the cell is empty and you get stuck on the outside loop if the cell is populated.
来源：https://stackoverflow.com/questions/49955615/attach-multiple-files-to-outlook-email-from-a-filtered-list-and-loop