Optimize VBA code that exports to PDF from MS Access - ms-access

I have two functions that will open and save two diffrent reports based on the same criteria. They are identical except for the refrences:
Function Export_MLR()
On Error GoTo Export_MLR_Err
Dim strReportName As String
DoCmd.OpenReport "Market Rate Notification Final", acViewPreview
strReportName = "S:\National Installations\Market Labor Rates\MLR_INV\MLR\" & Format (Reports![Market Rate Notification Final].Market_ID, "00") & " " & Replace(Reports![Market Rate Notification Final].Product_Code, " / ", "_") & "-" & "Market Rate Notification Final" & "_" & Format(Date, "mmddyy") & ".pdf"
DoCmd.OutputTo acOutputReport, "Market Rate Notification Final", "PDFFormat(*.pdf)", strReportName, False, , , acExportQualityScreen
DoCmd.Close acReport, "Market Rate Notification Final", acSaveNo
Export_MLR_Exit:
Exit Function
Export_MLR_Err:
MsgBox Error$
Resume Export_MLR_Exit
End Function
Then I created this function to select the data and put it into the table that the reports refrence line by line:
Function MassMarket()
On Error GoTo MassMarket_ERR
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
'this query creates my rs1 recordset'
DoCmd.SetWarnings (warningsOff)
DoCmd.OpenQuery "mass_market", acNormal, acEdit
DoCmd.SetWarnings (warningsOn)
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("Mass_market_Rate_change")
Set rs2 = db.OpenRecordset("tbl_Form_Auto")
'this checks and clears any records in rs2'
If rs2.EOF = False And rs2.BOF = False Then
rs2.MoveFirst
rs2.Delete
End If
rs1.MoveFirst
'loop goes through and adds 1 line runs reports saves them and deletes line'
Do Until rs1.EOF
Set rs2 = db.OpenRecordset("tbl_Form_Auto")
rs2.AddNew
rs2![MarketID] = rs1![MarketID]
rs2![Product_ID] = rs1![Product_ID]
rs2.Update
Call Export_Invoice
Call Export_MLR
rs1.MoveNext
rs2.MoveFirst
rs2.Delete
Loop
MassMarket_Exit:
Exit Function
MassMarket_ERR:
MsgBox Error$
Resume MassMarket_Exit
End Function
Now all of this worked like a charm but it created, on average 16 .pdf files per minute and I had to create 820 .pdf files(about 50 minutes). If this is the best I can do then I will take it but would love to cut this time in half if possible. Thanks for any and all input. NR

In a comment you indicated the bulk of the time is spent in your functions which export the reports to PDF. I'm uncertain whether we can speed those up.
It seems you open a report, reference a value in that report for use as part of the PDF file name, then call the OutputTo method with the same report name to save it as PDF.
In that situation, I'm uncertain what happens "under the hood" ... whether Access opens a second instance of the report object, or is smart enough to see that you already have an instance open and just use that one instead.
As a test, try to signal Access to use the first report instance. From the online help for the ObjectName parameter of the OutputTo method:
If you want to output the active object, specify the object's type for the ObjectType argument and leave this argument blank.
So what I'm suggesting is try this in your code:
DoCmd.OutputTo acOutputReport, , "PDFFormat(*.pdf)", _
strReportName, False, , , acExportQualityScreen
If Access complains, try it with an empty string for the ObjectName parameter.
DoCmd.OutputTo acOutputReport, "", "PDFFormat(*.pdf)", _
strReportName, False, , , acExportQualityScreen
I don't know how much (or even if) this suggestion will speed up your code. But if you can't speed up those export functions somehow, my hunch is your hope to cut the overall time by half is a shaky proposition.

Related

Splitting a report into separate emails with their individual reports

I am trying to send separate Employees a PDF/page of their section/report. The information is based on their EmployeeID (which is text not long number). So each person has their balance information on a page then there's a page break, and then next page shows the next person's details. With the code below, it does email each of the employees one page but it so happens to only email the first person's page to EVERYONE. Is it possible to somehow automate each week so that each user is emailed his/her individual page of the report?
Another error is that the email pop up one by one so I have to press send each time for over 200 people, and that the email seems to be sending to the email but then followed by #mailto:the email# for example email#email.com#mailto:email#email.com#
I just started Access and have been copying and scraping code off of places I have found online. Many thanks in advance, if you can assist!
Have a great day!
Private Sub cmdSendAll_Click()
Dim rsAccountNumber As DAO.Recordset
Dim strTo As Variant
Dim strSubject As String
Dim strMessageText As String
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Debug.Print strTo
With rsAccountNumber
Do Until .EOF
DoCmd.OpenReport "test", _
acViewPreview, _
WhereCondition:="EmployeeID = '" & !EmployeeID & "'", _
WindowMode:=acHidden
strTo = ![Email]
strSubject = "Updated Balance "
strMessageText = "Text Here"
DoCmd.SendObject ObjectType:=acSendReport, _
ObjectName:="test", _
OutputFormat:=acFormatPDF, _
To:=strTo, _
Subject:=strSubject, _
MESSAGETEXT:=strMessageText, _
EditMessage:=True
DoCmd.Close acReport, "Unaffirmed Report", acSaveNo
.MoveNext
Loop
.Close
End With
End Sub
Your opening a report called test and then closing another report called "Unaffirmed Report". You need to open and close the same report, in this case "test".
DoCmd.Close acReport, "test", acSaveNo. This should fix the employee data not updating, since the report remains open on the first employee.
To directly send the message you need change EditMessage:=True to EditMessage:=False.
Check the docs:
https://learn.microsoft.com/en-us/office/vba/api/access.docmd.sendobject
Also if you need to test this, set outlook in Offline mode, and run your code, check the messages in your Outbox to see if they're as expected. You can delete the messages from the Outbox to prevent them from being sent. Once you're finished with testing you can set Outlook back to Online Mode.
Regarding the email address issue, this comes automatically when using hyperlinks in your controls. You'll need to strip the extra part out with strTo = Left(![Email],InStr(![Email],"#")-1). Check your data if this will be valid for all email addresses. For a more advanced solution you can look at this post https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type.
Code provided as reference, please see the post for the explanation.
'copied from https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type
Public Function GetHyperlinkFullAddress(ByVal hyperlinkData As Variant, Optional ByVal removeMailto As Boolean) As Variant
Const SEPARATOR As String = "#"
Dim retVal As Variant
Dim tmpArr As Variant
If IsNull(hyperlinkData) Then
retVal = hyperlinkData
Else
If InStr(hyperlinkData, SEPARATOR) > 0 Then
' I append 4 separators at the end, so I don't have to worry about the
' lenght of the array returned by Split()
hyperlinkData = hyperlinkData & String(4, SEPARATOR)
tmpArr = Split(hyperlinkData, SEPARATOR)
If Len(tmpArr(1)) > 0 Then
retVal = tmpArr(1)
If Len(tmpArr(2)) > 0 Then
retVal = retVal & "#" & tmpArr(2)
End If
End If
Else
retVal = hyperlinkData
End If
If Left(retVal, 7) = "mailto:" Then
retVal = Mid(retVal, 8)
End If
End If
GetHyperlinkFullAddress = retVal
End Function
Consider using the MS Outlook object library to send emails. Whereas DoCmd.SendObject is a convenience handler, you control more of the process with initializing an Outlook application object and creating an Outlook email object setting all needed elements.
However, with this approach you need to first export your filtered report to PDF and then attach to email for final send. See inline comments for specific details.
Dim rsAccountNumber As DAO.Recordset
' CHECK Microsoft Outlook #.# Object Library UNDER Tools/References
Dim olApp As Outlook.Application, olEmail As Outlook.MailItem
Dim fileName As string, todayDate As String, strEmail As String
todayDate = Format(Date, "YYYY-MM-DD")
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Set olApp = New Outlook.Application
With rsAccountNumber
Do Until .EOF
' SETTING FILE NAME TO SAME PATH AS DATABASE (ADJUST AS NEEDED)
fileName = Application.CurrentProject.Path & "\Balance_Report_" & !EmployeeID & "_" & todayDate & ".pdf"
' OPEN AND EXPORT PDF TO FILE
DoCmd.OpenReport "test", acViewPreview, "EmployeeID = '" & !EmployeeID & "'"
' INTENTIONALLY LEAVE REPORT NAME BLANK FOR ABOVE FILTERED REPORT
DoCmd.OutputTo acReport, , acFormatPDF, fileName, False
DoCmd.Close acReport, "test"
' CREATE EMAIL OBJECT
strEmail = ![Email]
Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
.Recipients.Add strEmail
.Subject = "Updated Balance"
.Body = "Text Here"
.Attachments.Add fileName ' ATTACH PDF REPORT
.Send ' SEND WITHOUT DISPLAY TO SCREEN
End With
Set olEmail = Nothing
.MoveNext
Loop
.Close
End With
MsgBox "All emails successfully sent!", vbInformation, "EMAIL STATUS"
Set rsAccountNumber = Nothing: Set olApp = Nothing

Using MS Access Macro or VBA loop to print individual reports

I'm not at all familiar with VBA scripts, but I've tried a few scripts found here and elsewhere online without a lot of luck.
Currently I have a form where a user can press an "Export Report" command button, which opens a prompt asking for an [AgencyID] (a 5 digit id number). Once the user enters an [AgencyID] a report "rptAgencyReport" is launched which displays information from query "qryAgencyReport" using the criteria "Like [AgencyID]" to query fields from many tables in a print-friendly view. From here the user can either print the report or save it as pdf or rtf.
My problem is if we want to export a copy of all our files to .rtf format we have to manually select the "Export Report" button, enter the [AgencyID], then save the outputted file. For 600-700 individual reports this takes days to complete.
What I would like to do is rather than manually entering the [AgencyID] and running each report, I would like to batch export these reports to .rtf files using the [AgencyID] as the filename. I have a query "exportAgencyID" which contains a lists of all the [AgencyID]s I need to run, but I have not found a way to pass the [AgencyID] as a variable to the report and query.
I've looked at https://support.microsoft.com/en-us/kb/209790 but I don't know how to take each record from query "exportAgencyID" and use it as the input required for the query "qyrAgencyReport".
Query "exportAgencyID"
[AgencyID]
3
36
162
194
1190
1345
. . .
Query "qryAgencyReport"
Field: AgencyID
Table: AgencyMaster
Sort:
Show: checked
Criteria: Like [AgencyID]
tldr; Report displays results of query in a printable form; query results are based on the user entered [AgencyID]. How can I set the [AgencyID] input automatically from a table or query containing all the [AgencyID]s and export a record named [AgencyID].rtf for each [AgencyID]?
Anyone able to help a non-profit save a few days of repetitive work?
The question is a bit ambiguous, but I created a simple function that might help you out
Public Sub GetAgencyID()
Dim rst As Recordset
Dim db As Database
Dim strSQL As String
set db = CurrentDb
strSQL = "SELECT exportAgencyID.AgencyID FROM exportAgencyID ORDER BY exportAgencyID"
set rst = db.OpenRecordset(strSQL)
rst.MoveFirst
Do Until rst.EOF
DoCmd.OpenReport "rptAgencyReport", acViewPreview, , "AgencyID = " & rst!AgencyID
DoCmd.OutputTo acOutputReport, "rptAgencyReport", acFormatRTF, "C:\ReportsFromAccess\AgencyID." & rst!AgencyID & ".rtf"
docmd.close acReport, "rptAgencyReport"
rst.MoveNext
loop
rst.close
set rst = nothing
strSQL = ""
End Sub
C:\ReportsFromAccess requires you to have a folder named ReportsFromAccess in your C:\ drive. You can edit that to save it to where it needs to be saved. It should create a file like AGencyID1.rtf when AgencyID =1
Thank you #juan-castiblanco for the code. I needed to make a couple tweaks to get this to work. Below is the working code.
Private Sub GetAgencyID()
Dim rst As Recordset
Dim db As Database
Dim strSQL As String
Set db = CurrentDb()
Set rst = db.OpenRecordset("SELECT [AgencyID] FROM [exportAgencyID]")
rst.MoveFirst
Do Until rst.EOF
DoCmd.OpenReport "rptAgencyReport", acViewPreview, , "AgencyID = " & rst!AgencyID
DoCmd.OutputTo acOutputReport, "rptAgencyReport", acFormatRTF, "C:\Provider Profiles 2016\" & rst!AgencyID & ".rtf"
DoCmd.Close acReport, "rptAgencyReport"
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
strSQL = ""
End Sub

Saving Access Reports as PDF files

I am currently in the process of generating a report in access which, once generated, should be saved to a save location to user puts in.
Here's my block of code.
ReportName = "Appraisal_" & Trim(Str(Year)) & "_" & Me.empnr & "_" & Veilig(Me.empnr) & "_" & Format(Now(), "YYYY_MM_DD_HH_MM_SS")
DoCmd.CopyObject , ReportName , acReport, "rpt_beoordelen"
DoCmd.OpenReport ReportName , acViewPreview, , "EmployeeNr='" & Me.empnr & "' and year=" & Me.Year
DoCmd.OutputTo acOutputReport, "", acFormatPDF, , True
DoCmd.Close acReport, ReportName
This generates and displays the report with the correct values. It asks for save location. And, once given, tries to save the file to given location. It quickly flashes a printing PDF to give location window.
After this the program stops. No file can be found at the given location and the report is still opened. Debugging the application shows me that
DoCmd.Close acReport, ReportName
is never reached. I do not get a errormessage and i have no clue what is going wrong. Could anyone give me a solution to this problem?
If you are having trouble getting DoCmd.OutputTo to work with the "active object" by leaving ObjectName empty (ref: here) then you could try this:
Open the "rpt_beoordelen" report and save its Record Source query as a saved Query named "rpt_beoordelen_base_data". Create a "rpt_beoordelen_data" saved Query with some generic SQL like...
SELECT * FROM rpt_beoordelen_base_data
...then make "rpt_beoordelen_data" the Record Source for the [rpt_beoordelen] report.
Now change the code from your question to something like this:
ReportName = "Appraisal_" & Trim(Str(Year)) & "_" & Me.empnr & "_" & Veilig(Me.empnr) & "_" & Format(Now(), "YYYY_MM_DD_HH_MM_SS")
DoCmd.CopyObject , ReportName , acReport, "rpt_beoordelen"
Dim cdb As DAO.Database
Set cdb = CurrentDb
Dim qdf As DAO.QueryDef
Set qdf = cdb.QueryDefs("rpt_beoordelen_data")
qdf.SQL = "SELECT * FROM rpt_beoordelen_base_data WHERE EmployeeNr='" & Me.empnr & "' and year=" & Me.Year
Set qdf = Nothing
DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF
That will change your invocation of DoCmd.OutputTo to one that does not depend on the "active object" and may yield the results you desire. (FWIW, it's the only way I've gotten this method to work for generating PDF versions of reports.)

Split MS-Access reports into pdf's

I got the following VBA code from the web a while ago:
Private Sub btnCreatePDF_Click()
Dim MyPath As String
Dim MyFilename As String
MyPath = "D:\reports\"
MyFilename = "KS1.pdf"
'Open report preview and auto-save it as a PDF
DoCmd.OpenReport "Rpt_KS1", acViewPreview
DoCmd.OutputTo acOutputReport, "", acFormatPDF, MyPath & MyFilename, False 'Change false to true here to auto-open the saved PDF
'Close the previewed report
DoCmd.Close acReport, "Rpt_KS1"
End Sub
It was for use in MS Access to create a single pdf of reports (containing up to 30 pages) and works fine for what i needed. However, i now need to split the report into the 30 or so pages and create a pdf for each of the pages. Any idea how this can be done?
I have a 'username' in the report or can add a unique ID if this helps to split them etc.
Use the 4th parameter (WhereCondition) of Docmd.OpenReport. With the WhereCondition, do exactly what you would normally do when adding a Where to your query, only don't include the word Where. This will make the report only display records that match the WhereCondition.
Retrieve your list of unique identifiers into some sort of a collection, or recordset then do a loop. This example assumes that you have them in a collection called uniqueIds and will almost definitely require some modification by you.
Dim MyPath As String
Dim MyFilename As String
MyPath = "D:\reports\"
'Loop structure may vary depending on how you obtain values
For each uniqueId in uniqueIds
MyFilename = "KS1" & uniqueId & ".pdf"
'Open report preview and auto-save it as a PDF
DoCmd.OpenReport "Rpt_KS1", acViewPreview, , "uniqueField = " & uniqueID
DoCmd.OutputTo acOutputReport, "", acFormatPDF, MyPath & MyFilename, False
'Close the previewed report
DoCmd.Close acReport, "Rpt_KS1"
Next uniqueId
Strictly speaking, this may not result in a different PDF for each page. But it will generate a different PDF for each uniqueID, which might be every page depending on your data.

How to generate a PDF file from Access Report?

I'm having trouble trying to export an Access report to PDF format. Basically, I'm working on an old (built in 2001) Access database that uses forms as a user interface. Currently, you can send jobs from a "Jobs" form into an "Invoice" form. Once all the jobs are there, you simply click "Invoice All", specify a date and number of copies and this prints using an Access report as the template.
I've been tasked with adding a save as PDF function, but being a web designer by trade, I have very limited knowledge of Access and VB, but I do know a (very) little amount of ASP.Net and C# (how I got given this task is story for another time...)
In my mind I've approached this by creating a new PDF button on the Access form where they print the invoices. My thoughts are that I could simply duplicate the code for the printing and update to output to a PDF file instead. I can kind of get this working, but not how I'd like.
The code for the print function is below:
Private Sub cmdOpenGroupInvoice_Click()
Dim db As DAO.Database
Dim rsGetCustomerInvoice As DAO.Recordset
Dim rsInvoice As DAO.Recordset
Dim rsInvoiceAll As DAO.Recordset
Dim lngCusID As Long
Dim lngJobNo As Long
Dim iCountInvoice
Dim lngInvoiceNo As Long
Dim iNumberCopies As Integer
Dim sSQLGetInv As String
Dim sSQLInv As String
Dim datInvoiceDate As Date
sSQLGetInv = "SELECT tblJobs.JobNo,tblJobs.NetDespatchRef, tblLoads.Sales, tblLoads.PODName, tblLoads.TotalSales, tblLoads.Cost, tblLoads.Profit, tblJobs.SendToInvoice, tblJobs.Invoiced, tblJobs.MarkForHistory, tblJobs.CustomerID" & vbCrLf _
& "FROM tblJobs INNER JOIN tblLoads ON tblJobs.JobNo = tblLoads.JobNo" & vbCrLf _
& "WHERE (((tblJobs.SendToInvoice)=Yes) AND ((tblJobs.Invoiced)=No) AND ((tblJobs.MarkForHistory)=No));"
Set db = CurrentDb
Set rsGetCustomerInvoice = db.OpenRecordset(sSQLGetInv, dbOpenDynaset)
If rsGetCustomerInvoice.EOF Then
Beep
If MsgBox("There are no jobs to invoice", _
vbCritical + vbOKOnly, _
"No Jobs To Invoice") = vbOK Then
Exit Sub
End If
End If
rsGetCustomerInvoice.MoveLast
Debug.Print rsGetCustomerInvoice.RecordCount
rsGetCustomerInvoice.MoveFirst
Do Until rsGetCustomerInvoice.EOF = True
Set rsGetCustomerInvoice = db.OpenRecordset(sSQLGetInv, dbOpenDynaset)
If rsGetCustomerInvoice.EOF Then
rsGetCustomerInvoice.Close
db.Close
Set rsGetCustomerInvoice = Nothing
Set db = Nothing
DoCmd.Close acForm, "frmInvoiceDate"
Exit Sub
End If
Debug.Print rsGetCustomerInvoice.RecordCount
datInvoiceDate = CVDate(txtInvoiceDate)
lngInvoiceNo = GiveMeAnInvoiceNo()
lngCusID = rsGetCustomerInvoice.Fields!CustomerID
Call AddNewInvoice(lngInvoiceNo, datInvoiceDate, True)
Debug.Print iCountInvoice
lngJobNo = rsGetCustomerInvoice![JobNo]
Call SendThisJobToSageAll(lngCusID, datInvoiceDate, lngInvoiceNo)
Call InvoiceAll(lngCusID, lngInvoiceNo)
Dim strPODName As String
If Not IsNull(rsGetCustomerInvoice!NetDespatchRef) Then
If IsNull(rsGetCustomerInvoice![PODName]) Then
strPODName = " "
Else
strPODName = rsGetCustomerInvoice![PODName]
End If
'Call NetDesTrackingJobCompleate(rsGetCustomerInvoice![NetDespatchRef], rsGetCustomerInvoice![JobNo], strPODName)
End If
iCountInvoice = iCountInvoice - 1
'Debug.Print I
iNumberCopies = txtNumberOfCopies
Do Until iNumberCopies = 0
DoCmd.OpenReport "rptInvoice2", acViewNormal, , "[Invoice No]= " & lngInvoiceNo
iNumberCopies = iNumberCopies - 1
Loop
Form_frmInvoicing.Requery
rsGetCustomerInvoice.MoveNext
Loop
DoCmd.Close acForm, "frmInvoiceDate"
rsGetCustomerInvoice.Close
db.Close
Set rsGetCustomerInvoice = Nothing
Set db = Nothing
End Sub
With my original plan outlined above, I updated the below section to output to PDF:
Do Until iNumberCopies = 0
DoCmd.OpenReport "rptInvoice2", acViewNormal, , "[Invoice No]= " & lngInvoiceNo
DoCmd.OutputTo acOutputReport, "", acFormatPDF, MyPath & MyFilename, True
iNumberCopies = iNumberCopies - 1
Loop
Now this works and it does attempt to output a PDF file. The trouble is, it's runs the report and creates an invoice for every job in the system, rather than applying the report to JUST the jobs which are marked for invoicing.
I'm hoping this is happening because I've put the code in the wrong location, but I have a gut feeling that it's more complicated than that.
It's a bit of a long shot posting it on here, but I really appreciate any help at this point. I've also tried to keep this as short as possible, so if there's any details which aren't clear, I'll help out.
That is quite convoluted, so I think the simplest thing to do, if you do not wish to dive in and tidy up, is to modify the query that the report is based on.
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("MyReportQuery")
sSQL = "SELECT Whatever FROM MyTable WHERE [Invoice No]= " & lngInvoiceNo
qdf.SQL = sSQL
DoCmd.OutputTo acOutputReport, "rptInvoice2", acFormatPDF, _
MyPath & MyFilename, True
Unless you have Access 2007 with the Save as PDF Add-on or 2010, you may be best installing say, cutePDF, and printing to the PDF printer using DoCmd.PrintOut
I asked the same question a couple of years ago on UtterAccess..
There is a free library to do exactly what you need here: http://www.lebans.com/reporttopdf.htm
My original thread at UA is here : http://www.utteraccess.com/forum/Automatically-PDF-send-t1353547.html
I successfully used the library for a couple of years in several projects, mainly to generate quotes and invoices.
Hope this helps
PG