Send multiple PDF attachments via Outlook instead of single.

[NAT]

Hi all,

I have been developing our system at work for some months now and it's working brilliantly - Access is great!

We basically test samples and send the reports out daily to our customers via email. At this time I have put together a system which when you select "issue report" it opens the report by the correct ID, opens outlook and creates the email and adds the single PDF attachment.

A lot of the time we can have 5 - 20 PDF reports which have to go to the same client which are all sent individually at this time by clicking issue report next to each one. As you can imagine it would be so much better if I could select all of them for that company and all the PDF's go on the same email instead of single emails. I know you have to open a report in order to select the ID - Is is possible to attach multiple in one go?

I have posted the code we currently use below:

Private Sub btnEmailReport_Click()

Dim Filename As String
Dim Filepath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem

CompanyName = Me.CompanyName

If Dir("\\Server\\Reports\TestReports\" & CompanyName, vbDirectory) = "" Then
    MkDir Path:="\\server\Reports\Test Reports\" & CompanyName
    MsgBox "A new report storage folder has been setup for " & CompanyName & " as one didn't exist"""
Else
    'MsgBox ""
End If

Filename = "Test Report" & " " & Me.ReportID
Filepath = "\\server\Reports\Test Reports\" & CompanyName & "\" & Filename & ".pdf"

If Me.CompanyName = "CompanyA" Then
   DoCmd.OpenReport "RptSingleReportCompanyA", acViewPreview, , "SampleID = " & SampleID
   DoCmd.OutputTo acOutputReport, "RptSingleReportOmegaSW", acFormatPDF, Filepath
   DoCmd.Close acReport, "RptSingleReportCompanyA"
Else
   DoCmd.OpenReport "RptSingleReport", acViewPreview, , "SampleID = " & SampleID
   DoCmd.OutputTo acOutputReport, "RptSingleReport", acFormatPDF, Filepath
   DoCmd.Close acReport, "RptSingleReport"
End If

If oOutlook Is Nothing Then
    Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
     If IsNull(Me.PrimaryEmail) Then
        .To = "No email address in the system! Please enter one under Companies!"
     Else
        .To = Me.PrimaryEmail
        End If
    
    If IsNull(Me.CCEmail) Then
        .CC = ""
     Else
        .CC = Me.CCEmail
        End If
    .BCC = ""
    .Subject = "Your Report No:" & " " & Me.ReportID & ""
    .Body = "Dear" & " " & CompanyName & ", " & vbCrLf & vbCrLf & "Please see attached your report no: " & Me.ReportID & " Day" & vbCrLf & vbCrLf & "The email account(s) we have stored on our system can be seen below. If you would like to amend, remove or add additional email account(s), please reply to this email." & vbCrLf & "Primary Account: " & Me.PrimaryEmail & vbCrLf & "Additional Accounts: " & Me.CCEmail & vbCrLf & vbCrLf & " REMOVED TEXT for PRIVACY" & vbCrLf & "REMOVED TEXT for PRIVACY" & vbCrLf & vbCrLf & "REMOVED TEXT for PRIVACY"
    
    .Attachments.Add Filepath
    .Display
End With

Set emailitem = Nothing
Set oOutlook = Nothing
Me.ReportedCheckbox.Value = True
Me.FldReportedDate = Date
Me.FldReportedTime = Time()
DoCmd.RunCommand acCmdSaveRecord
[Forms]![MainPanel]![NavigationSubform].Requery
'delete temporary file
'Kill Filepath

End Sub

I have looked and looked for solutions - Any help will be so very greatly appreciated

Many thanks all

[ranman256]

usage:
Send1Email "bob@store.com", "your files " ,"here are the files"

'-------
'YOU MUST ADD THE OUTLOOK APP IN REFERENCES!!!   checkmark OUTLOOK OBJECTS in the vbE menu, Tools, References
'-------
Public Function Send1Email (ByVal pvTo, ByVal pvSubj, ByVal pvBody, optional pvFile ) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
dim vFile1, vFile2, vFile3, vDate

On Error GoTo ErrMail

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

vDate = format(date(),"yymmdd"
 
With oMail
    .To = pvTo
    .Subject = pvSubj & vDate
    .Body = pvBody

       .Attachments.Add vFile1, olByValue, 1    
       .Attachments.Add vFile2, olByValue, 1
       .Attachments.Add vFile3, olByValue, 1

   .Send
End With

EmailO = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume Next
End Function

[NAT]

Thank you, much appreciated.

Would you mind explaining some of this to me please?

Many thanks