Email Loop

[DMT Dave]

Hi Guy's, I am looping through a staff table to collect emails and send out 2 forms to each contact:
1: Holiday Calendar (PDFPath & PDFFile) Highlighted Red
2: Holiday Request Form (HolReqPath & HolReqFile) Highlighted Red

Because i have got the attachments within the loop, if there are 6 contacts, the email is attaching 12 forms to each email, is there an adjustment to the code below so there is only 2 attachments in each email but still loop through the contacts and generate 6 emails if there are 6 staff ? same applies if we add a staff record and it will loop through 7 emails and attach 2 each

Hope this makes sense

ps: not added full code because it's quite long

Set oEmailItem = oOutlook.CreateItem(olMailItem)Set rs = CurrentDb.OpenRecordset("Select * From tblStaff")
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do Until rs.EOF = True
myEmail = rs.Fields("Email")
FullName = Split(rs.Fields("Name"), " ")
Select Case UBound(FullName)
Case 0
fName = FullName(0)
Case 1
fName = FullName(0)
Case 2
fName = FullName(0) & " " & FullName(2)
End Select
a = TOD & " " & fName & ","
b = "We are now going to be sending you an updated Holiday Calendar and a copy of a holiday request form, 'only when changes have been made to the calendar' which you will also find on the notice board in the warehouse, this gives you the opportunity to plan any holidays from home."
c = "If you wish to start planning your holidays from your annual allowance, please note any days that are highlighted in yellow are already taken and are NOT available."
d = "Please note: we will endeavour to allocate your requested days unless days that you are requesting are already taken."
e = "Kind Regards"


Set OutAccount = oEmailItem.Session.Accounts.Item(1)
With oEmailItem
.To = rs.Fields("Email")
.Attachments.Add PDFPath & PDFFile
.Attachments.Add HolReqPath & HolReqFile
.subject = "Holiday Calendar " & Format(Now(), "yyyy") & " Update"
.HTMLBody = a & "<br>" & "<br>" & b & "<br>" & "<br>" & c & "<br>" & "<br> " & _
d & "<br>" & "<br>" & e & "<br>" & "<br>" & _
"<P><IMG border=0 hspace=0 alt='' src='file://T:/CompanyName/Logo Media/Email Signature.jpg' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
.SendUsingAccount = OutAccount
.Display
End With
rs.MoveNext
Loop

[Welshgasman]

You need to create the email within the recordset loop.

Try indenting your code as well. That makes it easier to find issues like this, though not this one.

[Gicu]

Hi Dave,
Can you try this?

Dim myEmail as String, FullName() as string
Dim PDFPath as string, PDFFile as string
Dim HolReqPath as string, HolReqFile as string
Dim sSubject as string,sHTMLBody as string


Set rs = CurrentDb.OpenRecordset("Select * From tblStaff")
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do Until rs.EOF = True
	myEmail = rs.Fields("Email")
	FullName = Split(rs.Fields("Name"), " ")
Select Case UBound(FullName)
Case 0
fName = FullName(0)
Case 1
fName = FullName(0)
Case 2
fName = FullName(0) & " " & FullName(2)
End Select
a = TOD & " " & fName & ","
b = "We are now going to be sending you an updated Holiday Calendar and a copy of a holiday request form, 'only when changes have been made to the calendar' which you will also find on the notice board in the warehouse, this gives you the opportunity to plan any holidays from home."
c = "If you wish to start planning your holidays from your annual allowance, please note any days that are highlighted in yellow are already taken and are NOT available."
d = "Please note: we will endeavour to allocate your requested days unless days that you are requesting are already taken."
e = "Kind Regards"




'Set OutAccount = oEmailItem.Session.Accounts.Item(1)
'With oEmailItem
'.To = rs.Fields("Email")
'.Attachments.Add PDFPath & PDFFile  'PDFPAth must end in \
'.Attachments.Add HolReqPath & HolReqFile


sSubject = "Holiday Calendar " & Format(Now(), "yyyy") & " Update"
sHTMLBody = a & "<br>" & "<br>" & b & "<br>" & "<br>" & c & "<br>" & "<br> " & _
d & "<br>" & "<br>" & e & "<br>" & "<br>" & _
"<P><IMG border=0 hspace=0 alt='' src='file://T:/CompanyName/Logo Media/Email Signature.jpg' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
'.SendUsingAccount = OutAccount
'.Display
'End With
	dmtSendEmail_Outlook(sSubject,myEmail,,PDFPath & PDFFile & "|" & HolReqPath & HolReqFile,sHTMLBody


rs.MoveNext
Loop


Public Function dmtSendEmail_Outlook(sSubject As String, sTo As String, Optional sCC As String, Optional sBcc As String, Optional sAttachment As String, Optional sBody As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutAccount as Object
    Dim sAttachments() as string,i as integer


    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutAccount = oEmailItem.Session.Accounts.Item(1)


    Set OutMail = OutApp.CreateItem(0)
    OutMail.SendUsingAccount = OutAccount
	
    OutMail.To = sTo
    If sCC <> "" Then OutMail.CC = sCC
    If sBcc <> "" Then OutMail.BCC = sBcc
    OutMail.Subject = sSubject
    OutMail.HTMLBody = sBody


    sAttachments=Split (sAttachment,"|")
    
    For i=0 to UBound(sAttachments)
          OutMail.Attachments.Add (sAttachments(i)) 
    Next i


    OutMail.Send 'Send | Display
    Set OutMail = Nothing
End Function


Set oEmailItem = oOutlook.CreateItem(olMailItem)

[DMT Dave]

Hi Vlad, thank you, will certainly..... Kindest

[DMT Dave]

Hi Vlad, i am getting an error in this

Copied your Public Function to my Modules called Public Functions

Then copied above you public function to a command button, the image is what the error comes up with

[Gicu]

Maybe the missing parenthesis at the end of the function?