I'm having an issue with an access form/report as it's not printing to the printer I've chosen from a combobox (that lists all the available printers).
I do know that I did create the report through the designer with the printer zebra-01 set and I think this is what might be causing the problem.
I have the following code to print labels from the report:
'Option Compare Database
Private Sub btnPrint_Click()
'Validate Input Given. If the input is less than or equal to 0 discard the print command.
'Two If statements, one for validating the input type and if the input is a positive number.
If IsNull(Me.txtNumberOfLabels) Or Not IsNumeric(Me.txtNumberOfLabels.Value) Then
MsgBox "O valor introduzido não é um valor numérico.", _
vbOKOnly, "Erro"
DoCmd.GoToControl "txtNumberOfLabels"
Exit Sub
End If
If Me.txtNumberOfLabels.Value <= 0 Then
MsgBox "O número de etiquetas a imprimir deve ser superior a 0", _
vbOKOnly, "Erro"
DoCmd.GoToControl "txtNumberOfLabels"
Exit Sub
End If
Dim availablePrinters As Printer
Dim selectedPrinter As String
DoCmd.GoToControl "cbPrintersList"
selectedPrinter = Me.cbPrintersList.Text
For Each availablePrinters In Application.Printers
If availablePrinters.DeviceName = selectedPrinter Then
Set Application.Printer = availablePrinters
Exit For
End If
Next availablePrinters
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim lastLabelRecordIndex_Part1 As String
Dim lastLabelRecordIndex_Part2 As String
Dim lastLabelRecordIndex_Part3 As String
Dim oldLastLabelRecordIndex_Part1 As String
Dim oldLastLabelRecordIndex_Part2 As String
Dim oldLastLabelRecordIndex_Part3 As String
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT MAX(Pre_SSCC) As MaxRecord FROM SSCC_Gen"
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
oldLastLabelRecordIndex_Part1 = CStr(Left(rs("MaxRecord"), 8))
oldLastLabelRecordIndex_Part2 = CStr(Mid(rs("MaxRecord"), 9, 4))
oldLastLabelRecordIndex_Part3 = CStr(Right(rs("MaxRecord"), 5))
rs.Close
db.Close
Dim labelRecordIndex As Long
DoCmd.SetWarnings False
For labelRecordIndex = CLng(oldLastLabelRecordIndex_Part3) To CLng(oldLastLabelRecordIndex_Part3) + Me.txtNumberOfLabels.Value - 1
DoCmd.RunSQL "INSERT INTO SSCC_GenCount (Data) VALUES (#" & Format(Now(), "dd/mm/yyyy") & "#)"
Next labelRecordIndex
DoCmd.SetWarnings True
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
lastLabelRecordIndex_Part1 = CStr(Left(rs("MaxRecord"), 8))
lastLabelRecordIndex_Part2 = CStr(Mid(rs("MaxRecord"), 9, 4))
lastLabelRecordIndex_Part3 = CStr(Right(rs("MaxRecord"), 5))
rs.Close
db.Close
Dim oldLastLabelRecordIndex As String
Dim lastLabelRecordIndex As String
oldLastLabelRecordIndex = oldLastLabelRecordIndex_Part1 & oldLastLabelRecordIndex_Part2 & CStr(oldLastLabelRecordIndex_Part3 + 1)
lastLabelRecordIndex = lastLabelRecordIndex_Part1 & lastLabelRecordIndex_Part2 & lastLabelRecordIndex_Part3
DoCmd.SetWarnings False
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, acViewPreview, , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
Set Report_Labels_SSCC_Gen.Printer = Application.Printers(Me.cbPrintersList.ListIndex)
'MsgBox Report_Labels_SSCC_Gen.Printer.DeviceName
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, , , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
DoCmd.Close acReport, Report_Labels_SSCC_Gen.Name, acSaveNo
DoCmd.SetWarnings True
End Sub
And this is the code to populate the combobox with the list of available printers, as soon as the form comes up:
Private Sub Form_Load()
Dim printerIndex As Integer
For printerIndex = 0 To Application.Printers.Count - 1
Me.cbPrintersList.AddItem (Application.Printers(printerIndex).DeviceName)
Next printerIndex
DoCmd.GoToControl "cbPrintersList"
End Sub
Now, according to dozens of articles I've read the whole day, the following bit of code should set the printer I want to print to, but it still keeps sending to the zebra-01 printer:
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, acViewPreview, , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
Set Report_Labels_SSCC_Gen.Printer = Application.Printers(Me.cbPrintersList.ListIndex)
'MsgBox Report_Labels_SSCC_Gen.Printer.DeviceName
DoCmd.OpenReport Report_Labels_SSCC_Gen.Name, , , "Pre_SSCC BETWEEN '" & CStr(oldLastLabelRecordIndex) & "' AND '" & CStr(lastLabelRecordIndex) & "'", acHidden
DoCmd.Close acReport, Report_Labels_SSCC_Gen.Name, acSaveNo
Can anyone explain to me what am I missing or doing wrong?
As a reference, here's what's happening before and after the printer is set to the report.printer property:
Before setting the printer
After setting the printer
You can clearly see from the debug that the report has its printer property set to the printer I've chosen from the combobox.
However, for some reason I cannot understand, right after that line of code, when running the OpenReport to print the labels, it prints to zebra-01 printer instead...
Personally, I use the following code to print reports to a specified printer:
DoCmd.OpenReport "SomeReport", acViewPreview
Set Reports("SomeReport").Printer = Application.Printers("SomePrinter")
DoCmd.SelectObject acReport, "SomeReport"
DoCmd.PrintOut
DoCmd.Close
This only works with reports that are not printing to the default printer, so first open up the report in design view, go to page setup, and choose Use specific printer, then pick a printer (any printer), to make sure the report won't be printed on the system default printer.
If you want to specify paper size and bin, you can do so after setting the report printer:
DoCmd.OpenReport "SomeReport", acViewPreview
Set Reports("SomeReport").Printer = Application.Printers("SomePrinter")
Reports("SomeReport").Printer.PaperSize = 1
Reports("SomeReport").Printer.PaperBin = 2
DoCmd.SelectObject acReport, "SomeReport"
DoCmd.PrintOut
DoCmd.Close
Getting the right numbers for the paper and bin numbers is a bit complicated, however. The process is outlined here: https://learn.microsoft.com/en-us/office/vba/access/concepts/printing/programmatically-retrieve-printer-capabilities
Related
I have a query in Access (Q_Invoices) that has separate records based on the invoice number (Invoice_Number). I also have a report that is linking to this query (R_Invoices_PDF). What I would like to do is to have VBA code to loop through each record in the query, and print the record as a separate PDF from the report.
I copied the following code from some website, and tried to adapt it for my purposes. It works to an extent. However, I stop it before it loops, and it saves all the records, not just the first one.
Private Sub cmd_GenPDFs_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
On Error GoTo Error_Handler
sFolder = "D:\Documents\Orchestra\Invoices\Invoice files\"
Set rs = CurrentDb.OpenRecordset("SELECT Invoice_Number FROM Q_Invoices", dbOpenSnapshot)
With rs
.MoveFirst
Do While Not .EOF
DoCmd.OpenReport "R_Invoices_PDF", acViewPreview, , "[Invoice_Number]=" & ![Invoice_Number], acHidden
sFile = Nz(![Invoice_Number], "") & ".pdf"
sFile = sFolder & sFile
DoCmd.OutputTo acOutputReport, "R_Invoices_PDF", acFormatPDF, sFile, acExportQualityPrint
'If you wanted to create an e-mail and include an individual report, you would do so now
DoCmd.Close acReport, "R_Invoices_PDF"
.MoveNext
Loop
End With
Application.FollowHyperlink sFolder 'Optional / Open the folder housing the files
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: cmd_GenPDFs_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Sub
I recall some issue with filtering the report. Thus, we filter the query that drives the report to return only data for a single invoice using a TempVars.
Here, Faktura means Invoice:
Private Sub FakturaPrint( _
ByVal PrintType As CdPrintType, _
Optional ByRef FullPath As String)
Const ReportName As String = "Faktura"
Const FileNameMask As String = "Faktura{0}.pdf"
Const FileIdMask As String = "kladde Job {0}"
Const CancelError As Long = 2212 ' Cactus TimeSag cannot print the object.
Const PrintError As Long = 2501 ' PrintOut was cancelled.
Dim Path As String
Dim FileName As String
Dim FileId As String
Dim PrintCount As Integer
Dim PrintCopy As Integer
On Error GoTo FakturaPrint_Click_Error
' Set filter on the source query of the report.
TempVars("FakturaID").Value = Me!FaktID.Value
Select Case PrintType
Case cdPrintPreview
DoCmd.OpenReport ReportName, acViewPreview, , , acWindowNormal
Case cdPrintPrinter
PrintCount = Nz(Me!UdskFakt.Column(2), 1)
If PrintCount < 1 Then
PrintCount = 1
End If
For PrintCopy = 1 To PrintCount
DoCmd.OpenReport ReportName, acViewNormal, , , acWindowNormal
Next
Case cdPrintPdf
Path = Environ("USERPROFILE") & "\Documents\"
FileId = Nz(Str(Me!Faktura.Value), Replace(FileIdMask, "{0}", Me!JobID.Value))
FileName = Replace(FileNameMask, "{0}", FileId)
' Return FullPath by reference for e-mail.
FullPath = Path & FileName
DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF, FullPath, False, , , acExportQualityPrint
End Select
FakturaPrint_Click_Exit:
Me!TextForClipboard.SetFocus
Exit Sub
FakturaPrint_Click_Error:
Select Case Err.Number
Case CancelError, PrintError
' Printing cancelled by user.
' Ignore.
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FakturaPrint_Click of Sub Form_Faktura"
End Select
Resume FakturaPrint_Click_Exit
End Sub
It is not a loop, but you can probably easily abstract from that.
I want to print each record to a separate pdf file using certain field for filename.
My code's output does not show the values as shown in the pictures.
Private Sub Command_PDF_Click()
Dim myrs As Recordset
Dim myPDF, myStmt As String
myStmt = "Select distinct Code1 from Query_Certificate_Eng"
Set myrs = CurrentDb.OpenRecordset(myStmt)
Do Until myrs.EOF
myPDF = "C:\Users\93167\Desktop\Output Certificate\" & Format(myrs.Fields("Code1"), "0000000000000") & ".pdf"
DoCmd.OpenReport "Certificate_Eng", acViewPreview, , "Code1" = " & myrs.Fields("").value"
DoCmd.OutputTo objectType:=acOutputReport, objectName:="Certificate_Eng", outputformat:=acFormatPDF, outputfile:=myPDF, outputquality:=acExportQualityPrint
DoCmd.Close
myrs.MoveNext
Loop
myrs.Close
Set myrs = Nothing
End Sub
Problem is in your report opening criteria. So, change it to
"Code1 = '" & myrs!Code1 & "'"
I'm using the code below to go thru a recordset and send individual reports to a person. Everything is working but the preview on the openreport on all but the first report are blank. Trying to figure out why if it sends the correct report to the person. It acts like it's opening a report and shows it then closes it but there's nothing but a blank page. Any thoughts would be appreciated!
Private Sub Command0_Click()
Dim daDb As DAO.Database
Dim daRs As DAO.Recordset
Dim sSql As String
sSql = "SELECT * FROM EmailedContributions;"
Set daDb = CurrentDb
Set daRs = daDb.OpenRecordset(sSql, dbOpenSnapshot)
Do Until daRs.EOF
Debug.Print daRs!MemberID
Debug.Print daRs!EmailName
DoCmd.OpenReport "Copy Of IRS Contribution Letter", acViewPreview, , "MemberID = " & daRs!MemberID, acWindowNormal
DoCmd.SendObject acSendReport, "Copy Of IRS Contribution Letter", acFormatPDF, daRs!EmailName, , , "IRS Contributions", "Attached are your contributions", False
DoCmd.Close acReport, "Copy Of IRS Contribution Letter"
Debug.Print daRs!EmailName
daRs.MoveNext
Loop
daRs.Close
Set daRs = Nothing
Set daDb = Nothing
End Sub
I have an Access 2016 database which use a form to select a time interval of 1 or more days.
A button let me to get the begin and end dates of the interval and do the follow 2 things:
a) build a query that, based on the dates, extracts a dataset from a table
b) open a pop-up form that show the dataset extracted by the query. There is no code on OpenForm event.
The magic is that everything works like a charm until I disable the Shift Bypass Key with the command
CurrentDb.Properties("AllowBypassKey") = False
After that the query still works well, but when the code try to open the form, 95% of the times, I get the error '2501 The OpenForm action was canceled', even if it worked well with Access 2013.
The code is quite simple, but after 3 days of hard work I still don't understand what is wrong. The only thing I got is that if I don't execute the CreateQueryDef instruction the error goes away and the form opens regoularly (even if it does not show the right dataset).
Therefore both the routine works alone, but they conflict if they run one after the other.
Below the code behind the button:
Private Sub Cmd_Meteo_Click()
On Error GoTo Err
Dim strFrmName As String
Dim datBegin As Date
Dim datEnd As Date
'Set the time interval
datBegin = Me.Txt_BeginTreatment 'Set the begin of the interval
datEnd = Me.Txt_Data 'Set tha end of the interval
'Build the query with meteo data
Call GetMetoData(Me.Txt_Region, Me.Cmb_MeteoStation, datBegin, datEnd, False)
'Set the form name
strFrmName = "Frm_DatiMeteoControllo"
'Check if the form is already open
If CurrentProject.AllForms(strFrmName).IsLoaded Then 'If the form is already open
DoCmd.Close acForm, strFrmName 'Close the form
End If
DoCmd.OpenForm strFrmName 'This line rise the 2501 error!
Exit_sub:
Exit Sub
Err:
MsgBox Err.Number & " " & Err.Description
Resume Exit_sub
End Sub
and the subroutine that build the query:
Public Sub GetMetoData(strRegion As String, intIdSM As Integer, datBegin As Date, datEnd As Date, bolTot As Boolean)
On Error GoTo Err
Dim db As DAO.Database
Dim strDbName As String
Dim qdf As DAO.QueryDef
Dim strSqlMeteo As String
Dim strLinkName As String
Dim strQryName As String
Set db = CurrentDb 'Set the db
strDbName = Application.CurrentProject.Name 'Get the db name
strTblName = GetMeteoTableName(strRegion, intIdSM) 'Get the name of the data table
strLinkName = "Tbl_DatiMeteo" 'Set the name of the linked table
strQryName = "TmpQry_DatiMeteoControllo" 'Set th name of the query
'SQL statement for the query
strSqlMeteo = "SELECT " & strLinkName & ".Data, ([" & strLinkName & "].[Precipitazione]) AS PrecTot, " & _
strLinkName & ".Tmin, " & strLinkName & ".Tmean, " & strLinkName & ".Tmax" & vbCrLf & _
"FROM " & strLinkName & vbCrLf & _
"WHERE (((" & strLinkName & ".Data) Between #" & Format(datBegin, "mm/dd/yyyy") & "# And #" & Format(datEnd, "mm/dd/yyyy") & "#));"
'Delete the previous query
If QueryEsiste(strDbName, strQryName) Then 'If the query already exist...
DoCmd.DeleteObject acQuery, strQryName 'delete the query.
End If
'Make the new query
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
Exit_sub:
qdf.Close
Set qdf = Nothing
db.Close
Set db = Nothing
Exit Sub
Err:
MsgBox Error$
Resume Exit_sub
End Sub
Does anyone has a hint or faced the same problem?
There should be no reason to delete the query:
If QueryEsiste(strDbName, strQryName) Then
' Modify the previous query.
Set qdf = db.QueryDef(strQryName)
qdf.SQL = strSqlMeteo
Else
' Create the new query.
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
End If
I have a database with 5 tables, 3 queries, 3 reports (the queries are the recordsets) and three reports each showing the several fields on the recordsets. The problem is, even though they have the same code, one of the sub routines has inconsistent results. It is like it is cycling through each supervisor and creating a report and then doing it again, it's caught in a loop and I can't see where the issue is. Hoping someone can help.
Private Sub cmdFedInvest_Click()
Dim x As String
Dim y As String
Dim StrSQL As String
Dim stWhereStr As String 'Where Condition'
Dim stSection As String 'Selection from drop down list
Dim stfile As String
Dim stDocName As String
Dim StrEmail As String
StrSQL = "SELECT DISTINCTROW [qryActT8_Sup].[Sup], [qryActT8_Sup].Sup_email " & _
"FROM [qryActT8_Sup];"
y = Year(Date)
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Dim qdTemp As DAO.QueryDef
Set qdTemp = db.CreateQueryDef("", StrSQL)
Set rst = qdTemp.OpenRecordset()
If rst.EOF And rst.BOF Then
MsgBox "No data available for the Ledger Process routine."
Else
Debug.Print rst.Fields.Count
rst.MoveFirst
Do While Not rst.EOF
x = rst![Sup]
StrEmail = rst![Sup_email]
stDocName = "FedInvest - ISSR - T8 Recertification Report"
stWhereStr = "[qryActT8_Sup].[SUP]= '" & x & "'"
stfile = Me.txtLocationSaveFI & "\" & x & " - " & y & " FedInvest Recertification.pdf"
DoCmd.OpenReport stDocName, acPreview, , stWhereStr
'DoCmd.SendObject acSendReport, stDocName, acFormatPDF, StrEmail, , , "2016 FedInvest Recertification", ""
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, stfile
DoCmd.Close acReport, stDocName
rst.MoveNext
Loop
End If
rst.Close
Set rst = Nothing
End Sub
You both open the report for preview and for output to PDF.
If only PDF is needed, skip the preview.