Inconsistencies in looping through and creating reports - vba

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.

Related

"dbo_" Missing From DNS-Less Connected Tables

I've had a DNS-less connection to my SQL Servers for years... but all of a sudden some (not all) of the tables are coming across WITHOUT the "dbo_" in the table name. I need the "dbo_" in the table names. It doesn't affect all the tables, just some of them. What's interesting is that it's the same tables that get the "dbo_" and the same ones that do not get it.
All tablenames in the table start with "dbo_". Nothing has changed in the DB nor the server for years. It's a 2019 SQL Server.
Any ideas on why its doing this?
Private Sub cmdLogin_Click()
On Error GoTo Err_Login
Dim varUserName As String
Dim varPassword As String
Dim vardim As String
Dim varCreds As String
varUserName = Me.txtUserName
varPassword = Nz(Me.txtPassword, vbNullString)
varCreds = "UID=" & varUserName & ";PWD=" & varPassword
vardim = ";APP=2007 Microsoft Office system;DATABASE=xyz"
strConnection = "ODBC;Driver={ODBC Driver 17 for SQL Server};Server=xyz;" & varCreds & ";APP=2007 Microsoft Office system;DATABASE=xyz"
Dim dbCurrent As DAO.Database
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Set dbCurrent = DBEngine(0)(0)
Set qdf = dbCurrent.CreateQueryDef("")
Dim td As TableDef
'Columns in ActiveTablesToLink: (DatabaseName, LinkFlag, LocalTableName, ServerName, SSTableName)
strsql = "SELECT * FROM ActiveTablesToLink WHERE LinkFlag = -1 And DatabaseName = 'xyz'"
Set recLocal = CurrentDb.OpenRecordset(strsql)
recLocal.MoveLast
recLocal.MoveFirst
strRecCount = recLocal.RecordCount
If strRecCount > 0 Then
Do While Not recLocal.EOF
stLocalTableName = recLocal!LocalTableName
stRemoteTableName = recLocal!SSTableName
Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, strConnection)
CurrentDb.TableDefs.Append td
recLocal.MoveNext
Loop
Else
End If 'Empty recordset
recLocal.Close
Application.RefreshDatabaseWindow
DoCmd.Close acForm, "Login"
Exit_cmdLogin: ' Label to resume after error.
Exit Sub
Err_Login:
If DBEngine.Errors.Count > 1 Then
'ODBC Error
For Each errany In DBEngine.Errors
MsgBox "ODBCExecute: Err# " & errany.Number & " raised by " _
& errany.Source & ": " & errany.Description, _
vbCritical, "cmdExecuteAttached()"
Next errany
Else 'Access Error
MsgBox "ODBCExecute: Err# " & Err.Number & " raised by " _
& Err.Source & ": " & Err.Description, _
vbCritical, "cmdExecuteAttached()"
End If
Resume Exit_cmdLogin
End Sub
Here is where you put the code just in case you need to fix this via VBA:
Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, strConnection)
' Add this line before he append
td.Name = stLocalTableName
CurrentDb.TableDefs.Append td
recLocal.MoveNext
Thanks to Tim Williams to finding the bug article:
https://answers.microsoft.com/en-us/msoffice/forum/all/has-version-2212-of-ms-access-affected-attaching/e730184f-db94-4fa8-b144-491c638df87c

Access Not Printing to the Printer Chosen

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

Saving Access Report with Distinct Name

I'm trying to save each individual employees statement using Access Reports. However I'm having issues with getting the Employee Name field to append to the MyFileName variable.
I'm able to export the individual employee reports as a PDF with the following format:
Statement_[EENo].pdf
However, I would like to have this to include the employee name in the following format:
Statement_[Employee Name]_[EENo].pdf
Private Sub Command2_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim MyFileName As String
Dim mypath As String
Dim temp As String
mypath = "FILE LOCATION"
Set db = CurrentDb()
Set rs = db.OpenRecordset("SELECT distinct [EENo] & [Employee Name] FROM [Query]", dbOpenSnapshot)
rs.MoveFirst
Do While Not rs.EOF
temp = rs("EENo" & "Employee Name")
MyFileName = "Statement" & "_" & [Employee Name] & "_" & Format(rs("EENo"), "000000") & ".PDF"
DoCmd.OpenQuery "1 - Query: Firm Admin_EE"
DoCmd.Close acQuery, "1 - Query: Firm Admin_EE", acSaveYes
DoCmd.OpenReport "REPORT", acViewReport, , "[EENo]=" & temp
DoCmd.OutputTo acOutputReport, "", acFormatPDF, mypath & MyFileName
DoCmd.Close acReport, "REPORT"
DoEvents
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
This should work:
temp = rs("EENo").Value & rs("Employee Name").Value
MyFileName = "Statement_" & rs("Employee Name").Value & "_" & _
Format(rs("EENo").Value, "000000") & ".PDF"
EDIT: I had not really looked at your SQL, and missed that you're combining the two columns in your query. I don't use access but try:
Set rs = db.OpenRecordset("SELECT distinct [EENo] , [Employee Name] FROM [Query]", _
dbOpenSnapshot)

Loop and copyfile combined in access 2016 vba

Private Sub Command203_Click() 'DOWNLOAD ALL ANNEXURES AT ONCE
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT IDRT FROM RT WHERE STRT=ME.IDMN")
'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until rs.EOF = True
Picker = "D:\1\" 'Destination path
path = [Forms]![1userselect]![APPENDIX] 'Get source file path
strFileName = Dir(path & IDRT & ".*")
Ext = Right(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
Dot = "."
S = path & IDRT & Dot & Ext
D = Picker & IDRT & Dot & Ext
FileCopy S, D
'Move to the next record. Don't ever forget to do this.
rs.MoveNext
Loop
Else
MsgBox "There are no annexures in this report."
End If
MsgBox "Finished downloadinng annexures."
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
End Sub
I am an auditor and have very very limited knowledge of VBA. The code above is a copy paste from different people. It will be helpful if some comments are added about what should be changed as it will help me to learn.
Task: Loop through record set and to get IDRT (this is the file name in the server folder) for the records having STRT as that on my form (Me.IDMN).
Problem: When I test SQL select statement in query builder I get filtered IDRT correctly. The copyfile mechanism is also tested separately and working well (if I give the IDRT myself in a text box).
Doesn't look like you're creating the SQL correctly.
Try:
Set rs = CurrentDb.OpenRecordset("SELECT IDRT FROM RT WHERE STRT=" & Me.IDMN)
if IDMN is numeric.
Or
Set rs = CurrentDb.OpenRecordset("SELECT IDRT FROM RT WHERE STRT='" & Me.IDMN & "'")
if text
Following code is now working:
Private Sub Command6_Click()
Dim rs As DAO.Recordset
Dim sourcePATH As String
Dim destinPATH As String
Dim StrSQL As String
Dim strFileName As String
Dim exten As String
Dim source As String
Dim destin As String
sourcePATH = "D:\1\"
destinPATH = "D:\2\"
StrSQL = "SELECT RT.STRT, RT.IDRT " & _
"FROM RT " & _
"WHERE (((RT.STRT) = " & Me.Text2 & "))"
Set rs = CurrentDb.OpenRecordset(StrSQL)
rs.MoveFirst
Do Until rs.EOF
strFileName = Dir(sourcePATH & rs!IDRT & ".*")
If Len(strFileName) = 0 Then
rs.MoveNext
Else
exten = Right(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
source = sourcePATH & rs!IDRT & "." & exten
destin = destinPATH & rs!IDRT & "." & exten
FileCopy source, destin
rs.MoveNext
End If
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub

Filtering dynamic SQL statement in MS Access 2010

I'm using MS Access 2010
I have a listbox to select the columns of my query, I would like to know is it possible to filter the first or the entire selection of the list box.
Below I have my code for the entire selection and process of getting the info to an empty query and filtering by the ship name and by the selection of the listbox (it works if I only select one field) but if I do multiple selection then i get this error.
The error message is
Run-Time error '3075'
Syntax error (comma) in query expression '(((q1_shcedule.ship) =[Forms]![dlg Manifest Report by date Selection]![dbShip] or IsNull([Forms]![dlg manifest report by date selection]![dcShip]))) AND (Jan_10, Jan_11)= "SH" Or (Jan_10, Jan_11) = "v"`
Any suggestions would be really appreciated.
Thanks.
Dim cdb As DAO.Database, qdf As DAO.QueryDef
Const queryName = "Manifest Report By Date Selection"
Dim strWhere As String
Dim strDate As String
Dim strEnd As String
Dim ctl As Control
Dim varItem As Variant
Dim Criteria As String
Dim itm As Variant
strWhere = "(" & CodeDate.Value & ")"
Set ctl = Me.CodeDate
For Each varItem In ctl.ItemsSelected
strWhere = strWhere & ctl.ItemData(varItem) & ", "
'Use this line if your value is text
'strWhere = (strWhere) & "'" & ctl.ItemData(varItem) & "',"
Next varItem
'trim trailing comma
strWhere = Left(strWhere, Len(strWhere) - 2)
strWhere = Right(strWhere, Len(strWhere) - 2)
Set cdb = CurrentDb
DoCmd.Close acQuery, queryName, acSaveNo
On Error Resume Next
DoCmd.DeleteObject acQuery, queryName
On Error GoTo 0
Set qdf = cdb.CreateQueryDef(queryName, _
"SELECT Q1_Schedule.[Resource Name], Gender, Company, Type, Position, Contract_End_Date, Q1_Schedule.IndividID, Q1_Schedule.Ship, Q1_Schedule.App, Q1_Schedule.SubApp, " + strWhere + " " & _
"FROM Resource INNER JOIN (Q4_Schedule INNER JOIN (Q3_Schedule INNER JOIN (Q2_Schedule INNER JOIN Q1_Schedule ON (Q2_Schedule.App = Q1_Schedule.App) AND (Q2_Schedule.Ship = Q1_Schedule.Ship) AND (Q2_Schedule.IndividID = Q1_Schedule.IndividID)) ON (Q3_Schedule.App = Q2_Schedule.App) AND (Q3_Schedule.Ship = Q2_Schedule.Ship) AND (Q3_Schedule.IndividID = Q2_Schedule.IndividID)) ON (Q4_Schedule.App = Q3_Schedule.App) AND (Q4_Schedule.Ship = Q3_Schedule.Ship) AND (Q4_Schedule.IndividID = Q3_Schedule.IndividID)) ON (Resource.IndividID = Q4_Schedule.IndividID) AND (Resource.IndividID = Q3_Schedule.IndividID) AND (Resource.IndividID = Q2_Schedule.IndividID) AND (Resource.IndividID = Q1_Schedule.IndividID) Where (((Q1_Schedule.Ship) = [Forms]![dlg Manifest Report by Date Selection]![dbShip] OR IsNull([Forms]![dlg Manifest Report by Date Selection]![dbShip]))) AND (" + strWhere + ") = ""SH"" Or (" + strWhere + ") = ""V"" ORDER BY Type DESC ")
' "ORDER BY Type DESC"
'Set qdf = cdb.OpenRecordset("Entire_Manifest", _
dbOpenDynaset, dbDenyRead)
Set qdf = Nothing
Set cdb = Nothing
DoCmd.OpenQuery queryName, acViewNormal, acEdit
Exit Sub
ErrorHandler:
MsgBox "Please Select A Range Of Date Or A Ship Name"
Print out your SQL string before creating the query and study it.