I want to scan 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.
My folder containing the PDFs looks like this:
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.
The code below will generate the email for person AAA and attach all three files listed above.
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 files, but doesn't attach BBB_111111.pdf.
For the third loop, the "do while mfe=" loop attaches the latter three files for CCC but doesn'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, 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.
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