I have attempted to write a macro that scans through a folder to pick relevant PDFs belonging to a person (such as AAA) and attach them to an email to be sent to AAA, then move on to pick up PDFs belonging to BBB and attach them to an email to be sent to BBB so on and so forth. My folder containing the PDFs looks like this:
- AAA_111111.pdf
- AAA_222222.pdf
- AAA_333333.pdf
- BBB_111111.pdf
- BBB_222222.pdf
- BBB_333333.pdf
- CCC_777777.pdf
- CCC_888888.pdf
- CCC_999999.pdf
- CCC_444444.pdf
The person is identified by the letters before the underscore (initials) and there is a list on another Excel tab that the initials are looked up against to return their email address.
I have written the code below and it works fairly well except it has an irritating flaw that I cannot solve. It will successfully generate the email for person AAA and attach all three files listed above for them. On the next pass of the main (outer) "do while" loop it comes to person BBB but the inner "do while mfe=" loop attaches the second and third file listed for them (BBB_222222.pdf & BBB_333333.pdf) and completely ignores BBB_111111.pdf (doesn't attach it) though it seems to be able to see it on. Ditto for the third loop, the "do while mfe=" loop will attach the latter three files for CCC to an email but won't attach CCC_777777.pdf?!
Sub emailreports()
Dim OutApp As Object
Dim OutMail As Object
Dim OMail As Object, signature, mfe, sto As String
Dim emaillastrow, x, a As Long
Dim fso As Scripting.FileSystemObject
Set fso = New FileSystemObject
Dim folder, strfile As String
Dim rundate As Date
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.AutoRecover.Enabled = False
folder = Worksheets("START").Range("A14")
strfile = Dir(folder)
rundate = Worksheets("TEMPLATE").Range("E7")
b = Worksheets("START").Range("H25")
Sheets("EMAIL").Select
emaillastrow = Worksheets("EMAIL").Range("A1000000").End(xlUp).Row
If Dir(folder, vbDirectory) = "" Then
MsgBox "PDF destination file path doesn't exist.", vbcritial, "Path error"
Exit Sub
End If
Do While Len(strfile) > 0
Filename = fso.GetBaseName(folder & strfile)
mfe = Left(Filename, InStr(Filename, "_") - 1)
For x = 2 To emaillastrow
If mfe = Worksheets("EMAIL").Range("A" & x) Then
sto = sto & ";" & Worksheets("EMAIL").Range("B" & x)
End If
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
End With
With OutMail
.To = LCase(sto)
.CC = ""
.BCC = ""
.Subject = "Test subject text"
Do While mfe = Left(Filename, InStr(Filename, "_") - 1)
.Attachments.Add (folder & Filename)
Filename = Dir
If Filename = "" Then
Exit Do
End If
Loop
.signature.Delete
.HTMLBody = "<font face=""arial"" style=""font-size:10pt;"">" & "Test email body text" & .HTMLBody
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing
Skip:
sto = ""
strfile = Filename
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.AutoRecover.Enabled = True
End Sub
I thought about trying to make it somehow at the end of generating the email to take a step back but being a Do loop this is not possible. My code seems to ignore the PDF that it stopped at as part of the previous email generation and when generating the next email starts from that PDF file but only picks up and attaches subsequent PDFs. Any help would be gratefully received as I've tried all sort of things but can't make it work. This is my first post to Stackoverflow so apologies if my question and/or format is not correct or appropriate.
CodePudding user response：
On Error Resume Next seems to mask errors and hide skip reason. Try to use more specialized filename mask:
...
folder = Worksheets("START").Range("A14")
If Dir(folder, vbDirectory) = "" Then
MsgBox "PDF destination file path doesn't exist.", vbcritial, "Path error"
Exit Sub
End If
strfile = Dir(fso.BuildPath(folder, "*_*.pdf")
rundate = Worksheets("TEMPLATE").Range("E7")
b = Worksheets("START").Range("H25")
'Sheets("EMAIL").Select 'no need to select a sheet
emaillastrow = Worksheets("EMAIL").Range("A1000000").End(xlUp).Row
...
CodePudding user response：
You could use a dictionary object to group together the filenames by prefix with one pass of the directory and then iterate the dictionary keys to create the emails with corresponding attachments. For example (outlook methods untested)
Option Explicit
Sub emailreports()
Dim dict As Scripting.Dictionary, key
Set dict = New Scripting.Dictionary
Dim folder As String, strfile As String, mfe As String
Dim sTo As String, arPDF, arAddr, f
Dim ws As Worksheet, r As Long, emaillastrow As Long
folder = Worksheets("START").Range("A14")
strfile = Dir(folder & "*.pdf")
If strfile = "" Then
MsgBox "PDF destination file path doesn't exist.", vbCritical, "Path error " & folder
Exit Sub
Else
' group files by prefix
Do While strfile <> ""
mfe = Left(strfile, InStr(strfile, "_") - 1)
If dict.Exists(mfe) Then
dict(mfe) = dict(mfe) & vbTab & strfile
Else
dict.Add mfe, strfile
End If
strfile = Dir ' get next pdf
Loop
End If
Set ws = Worksheets("EMAIL")
emaillastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' read email address lookup into array
arAddr = ws.Range("A2:B" & emaillastrow)
' prepare one email per key
Dim OutApp As Object, OutMail As Object, OMail As Object
'Set OutApp = CreateObject("Outlook.Application")
For Each key In dict.Keys
' build array of file names for one key
mfe = Trim(key)
arPDF = Split(dict(mfe), vbTab)
' get email addresses
sTo = ""
For r = 1 To UBound(arAddr)
If mfe = arAddr(r, 1) Then
sTo = sTo & arAddr(r, 2) & ";"
End If
Next
Debug.Print key, sTo
'Set OutMail = OutApp.CreateItem(0)
'With OutMail
'.To = LCase(sTo)
'.cc = ""
'.BCC = ""
'.Subject = "Test subject text"
' attach pdfs
For Each f In arPDF
'.Attachments.Add folder & f
Debug.Print , folder & f
Next
'.signature.Delete
'.HTMLBody = "<font face=""arial"" style=""font-size:10pt;"">" & "Test email body text" & .HTMLBody
'.Display
'End With
Next
'OutApp.quit
End Sub