The below code attaches one file per email. I need to attach seven files from the folder.
I have approximately 150 files.
I need to
In the first email attach the first 7 files and then loop to attach 7 files to each subsequent email then in the last email attach the remaining three PDF files.
Subject for the first email: Invoice 001 to Invoice 007
Body for First Email:
Please find attached the following invoices
Invoice 001 to Invoice 007 (7 invoices)
...
Subject for the last email: Invoice 148 to Invoice 150
Body for last Email:
Please find attached the following invoices
Invoice 148 to Invoice 150 (3 invoices)
Sub sendmailsss()
Dim path As String
Dim counter As Integer
counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet").Range("M2")
If ThisWorkbook.Worksheets("Sheet").Range("M2") = "" Then
MsgBox "No folder selected. Please Select a folder with Invoives."
Exit Sub
End If
fpath = path & "\*.pdf"
fname = Dir(path)
Dim OutApp As Outlook.Application
Dim Source As String
Dim subj() As String
Do While fname <> ""
subj = Split(fname, ".")
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutAccount = OutApp.Session.Accounts.Item(2)
Set OutMail = OutApp.CreateItem(olMailItem)
Source = path & fname
With OutMail
.To = "[email protected]"
.Subject = "Company Ltd " & subj(0)
.HTMLBody = "Invoice attached"
.Attachments.Add Source
.SendUsingAccount = OutAccount
'.Display
.Send
End With
If Err Then
MsgBox "Error while sending Email" & vbLf & "Press OK to check it in the Outlook", vbExclamation
'.Display
Else
ms = ms 1
End If
On Error GoTo 0
Application.Wait Now #12:00:10 AM#
fname = Dir()
'If ms = 3 Then
' Exit Do
'End If
Loop
MsgBox "Process Completed. " & ms & " emails sent."
End Sub
CodePudding user response：
Here is the re-built code:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path)
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "[email protected]"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
CodePudding user response：
You should be able to adapt this into your existing code. What you need to do I think is add all the references to the attachment files to an array first. This will allow you to loop over them according to your specific counting requirements of 7 per e-mail:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path & "\*.pdf")
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "[email protected]"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
I'm not sure what "subj" or "counter" are supposed to be doing in your code so I have commented them out. I cannot 100% test this, because I don't have Outlook on this machine, but it should give you the idea of how the looping will work.