Access VBA - Generating Email attaching multiple reports combined into 1 PDF

[Jesse]

Hi Folks,

Disclaimer - I'm no expert in VBA nor Access so please excuse my ignorance and lack of proper coding terms.

Overview - I have a DB that creates a set of reports for an individual user, generates an email, and attaches a combined pdf with a summary of reports for that user. I have two users groups: Individual employees, and managers. For individual employees, my "combinePDF" code works to combine multiple reports into one attachment. As a new requirement, I'm looking to add the same functionality for all manager reports (2).

How it works(or supposed to)

pass three variables into the "combinePDF" function: Report to be sent, userID, and directory
Create individual objects for each applicable PDF report
Logic to evaluate which report is coming in: Employee reports OR Manager Reports
Create directory and destination to store PDF's reports, confirm the report should exist, output relevant reports to destination
The combined report is picked up from the destination with an email function and sent to the user


Problem - When re-creating the code to combine the manager reports into one PDF and store them in the destination folder for email extraction; the second report is not being sent. When checking if my report should exist(see snippet below) by running a query against my db, the line in red behaves different than expected. Specifically,instead of connecting to the DB , running the select statement, and moving to the next IF statement, it skips to a different step in another function and does not complete the "CombinePDF" function. Totally confused as to why since the individual report uses the same logic but does not have this issue.

Code Snippet
strSql = "SELECT * FROM qry_ManagerDirectsDevicesFiltered WHERE [ManagerID] = '" & sourceUserID & "';"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)
If rs.RecordCount > 0 Then
'Do
'Open the source document that will be added to the destination
DoCmd.OutputTo acOutputReport, Source4Name, acFormatPDF, directory & Source4Name & ".pdf", False
PDFSource4.Open (directory & Source4Name & ".pdf")
If PDFDestination.InsertPages(PDFDestination.GetNumPages - 1, PDFSource4, 0, PDFSource4.GetNumPages, 0) Then
'-1 Success
Else
'0 problem
End If



Below is the full set of code for the CombinePDF function:
Function CombinePDF(reportToSend As Variant, sourceUserID As Variant, directory As String)
'Relies on the Adobe Acrobat 9.0 Type Library
Dim PDFDestination As Acrobat.AcroPDDoc
Dim PDFSource1 As Acrobat.AcroPDDoc
Dim PDFSource2 As Acrobat.AcroPDDoc
Dim PDFSource3 As Acrobat.AcroPDDoc
Dim PDFSource4 As Acrobat.AcroPDDoc


Dim DestinationName As String
Dim Source1Name As String
Dim Source2Name As String
Dim Source3Name As String
Dim Source4Name As String




'Initialize the objects
Set PDFDestination = CreateObject("AcroExch.PDDoc")
Set PDFSource1 = CreateObject("AcroExch.PDDoc")
Set PDFSource2 = CreateObject("AcroExch.PDDoc")
Set PDFSource3 = CreateObject("AcroExch.PDDoc")
Set PDFSource4 = CreateObject("AcroExch.PDDoc")




'NOTE: Source files are only applicable for Individual Report
' The manager report currently only uses a single report (trying to change this with the code below)


Dim rs As DAO.Recordset, qry As DAO.QueryDef
Dim db As DAO.Database


'Create and combine reports for individual report
If (reportToSend = "Rpt_Employees") Then
DestinationName = "rpt_Employees_Summary"
Source1Name = "rpt_Employees"
Source2Name = "rpt_Employees_Audio"
Source3Name = "rpt_EmployeeAssets"

'Open Destination, all other documents will be added to this and saved with
'a new filename
DoCmd.OutputTo acOutputReport, DestinationName, acFormatPDF, directory & DestinationName & ".pdf", False
PDFDestination.Open (directory & DestinationName & ".pdf")

'Determine if user has cellular devices; create and add cellular report
'NOTE: This is NOT the query used to populate the report; it just validates that the report should exist
Set db = CurrentDb
strSql = "SELECT * FROM qry_InvoiceLine WHERE sapUserID = '" & sourceUserID & "' AND DateOfInvoice BETWEEN #" & Forms!frm_Employees!StartDate & "# AND #" & Forms!frm_Employees!EndDate & "#;"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)

If rs.RecordCount > 0 Then
DoCmd.OutputTo acOutputReport, Source1Name, acFormatPDF, directory & Source1Name & ".pdf", False
PDFSource1.Open (directory & Source1Name & ".pdf")
If PDFDestination.InsertPages(PDFDestination.GetNumPages - 1, PDFSource1, 0, PDFSource1.GetNumPages, 0) Then
'-1 Success
Else
'0 problem
End If
PDFSource1.Close
End If
rs.Close

'Determine if user has audio conferencing charges; create and add audio conferencing report
strSql = "SELECT * FROM ATT_Audio_Domestic WHERE [Enterprise ID] = '" & sourceUserID & "' AND InvoiceMonth BETWEEN #" & Forms!frm_Employees!StartDate & "# AND #" & Forms!frm_Employees!EndDate & "#;"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)
If rs.RecordCount > 0 Then
'Do
'Open the source document that will be added to the destination
DoCmd.OutputTo acOutputReport, Source2Name, acFormatPDF, directory & Source2Name & ".pdf", False
PDFSource2.Open (directory & Source2Name & ".pdf")
If PDFDestination.InsertPages(PDFDestination.GetNumPages - 1, PDFSource2, 0, PDFSource2.GetNumPages, 0) Then
'-1 Success
Else
'0 problem
End If
PDFSource2.Close
'Loop
End If
rs.Close

'Determine if the user has assets; create and add Employee Assets Report
strSql = "SELECT * FROM Assets WHERE [UserID] = '" & sourceUserID & "' ;"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)
If rs.RecordCount > 0 Then
'Do
'Open the source document that will be added to the destination
DoCmd.OutputTo acOutputReport, Source3Name, acFormatPDF, directory & Source3Name & ".pdf", False
PDFSource3.Open (directory & Source3Name & ".pdf")
If PDFDestination.InsertPages(PDFDestination.GetNumPages - 1, PDFSource3, 0, PDFSource3.GetNumPages, 0) Then
'-1 Success
Else
'0 problem
End If
PDFSource3.Close
'Loop
End If
rs.Close


ElseIf (reportToSend = "rpt_DirectReports") Then
DestinationName = "rpt_DirectReports"
Source4Name = "rpt_ManagerDirectsAssets"

'Open Destination, all other documents will be added to this and saved with
'a new filename
DoCmd.OutputTo acOutputReport, DestinationName, acFormatPDF, directory & DestinationName & ".pdf", False
PDFDestination.Open (directory & DestinationName & ".pdf")


'Determine if the users directs have assets(pc, tablet, network card, servers, etc..)
'; create and add Manger Directs device report
Set db = CurrentDb

strSql = "SELECT * FROM qry_ManagerDirectsDevicesFiltered WHERE [ManagerID] = '" & sourceUserID & "';"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)
If rs.RecordCount > 0 Then
'Do
'Open the source document that will be added to the destination
DoCmd.OutputTo acOutputReport, Source4Name, acFormatPDF, directory & Source4Name & ".pdf", False
PDFSource4.Open (directory & Source4Name & ".pdf")
If PDFDestination.InsertPages(PDFDestination.GetNumPages - 1, PDFSource4, 0, PDFSource4.GetNumPages, 0) Then
'-1 Success
Else
'0 problem
End If
PDFSource4.Close
'Loop
End If
rs1.Close

End If


'Save and close the file
'This is run for the manager directs report
PDFDestination.Save PDSaveFull, directory & reportToSend & ".pdf"
PDFDestination.Close


'Return the PDFDestination and reset variables
CombinePDF = PDFDestination
Set PDFSource1 = Nothing
Set PDFSource2 = Nothing
Set PDFSource3 = Nothing
Set PDFSource4 = Nothing
Set PDFDestination = Nothing

[jonh]

"it skips to a different step in another function"

At a guess, your code is erroring and jumping back to a procedure that contains an error handler.

e.g. in this case, j would not get set to 2 because i caused an unhandled error which forces the flow of execution back up to Test()


Private Sub Test()
On Error Resume Next
doError
End Sub

Private Sub doError()
Dim i As Integer
i = "1"
j = 2
End Sub

[Jesse]

Didn't even think of error handling. So yes, the other function that it reverts back to is sendreport() [see full code below], the code that actually adds the attachment and sends the email. It does have error handling. It basically exits the CombineReport function and resume's with the piece of code that attaches the PDF and sends the email. The specific line of code is: msgOne.AddAttachment (userIDFolder & reportToSend & ".pdf") [Also highlighted below]

Any idea what might be causing the error?


Code below

'report needs to be opened before this is called
'Function with four input parameters for email services
Function sendReport(sourceUserID As Variant, subjectLine As String, messageBody As String, reportToSend As Variant)

On Error Resume Next
Dim userIDFolder As String

'sets variables "subjectLine" and "messageBody" equal to the returned value of function "getVar",
subjectLine = getVar(subjectLine)
messageBody = getVar(messageBody)

'If folder has not been initialized, give default value
If folder = "" Then
folder = "C:\Temp\MyServices"
End If

'If "folder" does not exist, create it
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folder) Then
fso.createfolder (folder)
End If

'Create the userID folder
userIDFolder = folder & "\" & sourceUserID
If fso.FolderExists(userIDFolder) Then
fso.deletefolder (userIDFolder)
End If
fso.createfolder (userIDFolder)
userIDFolder = userIDFolder & "\"

'Validates report name
If Not (reportToSend = "rpt_Employees") Then
If Not (reportToSend = "rpt_DirectReports") Then
If Not (reportToSend = "rpt_EmployeeAssets") Then
If Not (reportToSend = "rpt_ManagerDirectsAssets") Then
If IsNull(DLookup("shSapID", "StakeHolders", "shSapID='" & reportToSend & "'")) Then
reportToSend = DLookup("shSapID", "StakeHolders", "realName='" & reportToSend & "'")
End If
End If
End If
End If
End If


Dim cdoConfig
Dim msgOne
Dim msgTwo

'Configures email server connection using the [excluded for confidentiality] SMTPserver
Set cdoConfig = CreateObject("CDO.Configuration")

With cdoConfig.Fields
.Item("[excluded for posting purposes]/cdo/configuration/sendusing") = excluded for confidentiality
.Item("[excluded for posting purposes]/cdo/configuration/smtpserverport") = port excluded for confidentiality
.Item("[excluded for posting purposes]/cdo/configuration/smtpserver") = "[server excluded for confidentiality]"
.Item("[excluded for posting purposes]/cdo/configuration/smtpauthenticate") = excluded for confidentiality
.Item("[excluded for posting purposes]/cdo/configuration/sendusername") = "[username excluded for confidentiality]"
.Item("[excluded for posting purposes]/cdo/configuration/sendpassword") = "[password excluded for confidentiality]"
.Update
End With

'Configure emails - From, Subject, and Body fields
Set msgOne = CreateObject("CDO.Message")
Set msgOne.configuration = cdoConfig
'msgOne.from = getVar("emailFromField")
msgOne.from = "[generic email excluded for confidentiality]"
msgOne.Subject = subjectLine & " " & sourceUserID
msgOne.TextBody = messageBody

If IsArray(reportToSend) Then
For i = 0 To UBound(reportToSend)
DoCmd.OutputTo acOutputReport, reportToSend(i), acFormatPDF, userIDFolder & reportToSend(i) & ".PDF", False
msgOne.AddAttachment (directory & reportToSend(i) & ".PDF")
Next i

Else
'Simple Desc: Runs a function used to create and generate user report in PDF format
'Technical Desc: Calls "CombinePDF" function to create and combine the reports
reportToSend = CombinePDF(reportToSend, sourceUserID, userIDFolder)
msgOne.AddAttachment (userIDFolder & reportToSend & ".pdf")

End If

'Simple Desc: This section of the code loops through a set of code that creates the email distribution list to send reports
'Technical Desc: Section of code uses Data validation, for loop, "getEmail" function to capture current email of user to send each report.

Dim toList As String

toList = ""
'Data validation, identifying if variable "sourceUserID" is array - arrays no longer used
If IsArray(sourceUserID) Then
For i = 0 To UBound(sourceUserID)
'use of "getEmail" capturing current UserID
toList = toList & getEmail(sourceUserID(i) & "") & "; "
Next i
Else
toList = getEmail(sourceUserID & "")
End If
'Simple Desc: This one line of code populates the "To" field with the Email distribution list from the database.
msgOne.To = toList

'this one line of code actually sends the email
msgOne.send

End Function

[jonh]

The error is on the code you posted first
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)

put a breakpoint on
msgOne.AddAttachment (userIDFolder & reportToSend & ".pdf")

run the code and when it stops type ?err.description in the immediate window. That should tell you what the error is.

[Jesse]

When doing this I get the message: Too few parameters. Expected 1. Any ideas? I used the same parameters as the code for the individual report but it behaves differently. Also tested the query to ensure there were no missing parameters from the form. Everything seems to be working fine there.

[jonh]

If it's a parameter query you need to set the parameter values. e.g.

SELECT id, a FROM Table1
where a = [what?]

Set qd = db.QueryDefs(myqry)
qd.Parameters("what?") = "foobar"
Set rs = qd.OpenRecordset

[Jesse]

So this is the code I'm using to run my parameter query:

strSql = "SELECT * FROM qry_ManagerDirectsDevicesFiltered WHERE [ManagerID] = '" & sourceUserID & "';"
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot, dbReadOnly)

Setting strSQL = to a select statement that captures the userID that is selected on one of my forms then using the DB.Openrecordset to run it. The output of this string comes as: SELECT * FROM qry_ManagerDirectsDevicesFiltered WHERE [ManagerID] = 'MyUserID';

When running this query in Access, it runs just fine which leads me to believe there are no issues with the query parameter. What might I be missing? Would it help to save the query in access and run it as opposed to writing the entire statement in VBA?

Thanks,

Jesse

[jonh]

I can only think of two reasons you would get that error.
1) Access can't find the field 'ManagerID'. It's either spelled wrong or is not part of the query. This doesn't seem likely since you say the query runs ok.
2) qry_ManagerDirectsDevicesFiltered is a parameter query (you get an input box to enter a value when you run it.) In which case you need to set the values like in the example above; you can't set a parameter's value from a where clause.