I have a consistent bug with my code I’m hopping someone can help with. The code takes a report and creates a pdf for each record and saves it locally with a unique name. It accomplishes what its designed to do except if it creates 10 pdf’s all will have correct names but only 9 are perfect, one file will have all records in it.
Creating pdf’s with Intermittent problem
- Thread starter earls
- Start date
isladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
Several things
1. Which contains all the records? The first or last presumably?
2. Why do you set qdf.sql repeatedly? I think you only need to do it once.
3. Suggest you concatenate using & rather than +, though that's not going to solve this issue
4. Try adding Rs.MoveLast followed by Rs.MoveFirst at the start of yourloop
1. Which contains all the records? The first or last presumably?
2. Why do you set qdf.sql repeatedly? I think you only need to do it once.
3. Suggest you concatenate using & rather than +, though that's not going to solve this issue
4. Try adding Rs.MoveLast followed by Rs.MoveFirst at the start of yourloop
Thanks for your help. I’m a novice and the code was created by someone else, I have made minimal modifications to it to get it to this point.
Several things
1. Which contains all the records? The first or last presumably?
tblTrips contains all records.
2. Why do you set qdf.sql repeatedly? I think you only need to do it once.
I have no idea why original developer set it up this way.
3. Suggest you concatenate using & rather than +, though that's not going to solve this issue
Done.
4. Try adding Rs.MoveLast followed by Rs.MoveFirst at the start of yourloop
I added both lines no luck.
I did notice that the oldest ID# in the report gets all records dumped into it. It’s as if the first loop it creates a master (but uses an ID for name) than starts the process for the rest.
Thanks for your help. I’m a novice and the code was created by someone else, I have made minimal modifications to it to get it to this point.
Several things
1. Which contains all the records? The first or last presumably?
tblTrips contains all records.
2. Why do you set qdf.sql repeatedly? I think you only need to do it once.
I have no idea why original developer set it up this way.
3. Suggest you concatenate using & rather than +, though that's not going to solve this issue
Done.
4. Try adding Rs.MoveLast followed by Rs.MoveFirst at the start of yourloop
I added both lines no luck.
I did notice that the oldest ID# in the report gets all records dumped into it. It’s as if the first loop it creates a master (but uses an ID for name) than starts the process for the rest.
Several things
1. Which contains all the records? The first or last presumably?
tblTrips contains all records.
2. Why do you set qdf.sql repeatedly? I think you only need to do it once.
I have no idea why original developer set it up this way.
3. Suggest you concatenate using & rather than +, though that's not going to solve this issue
Done.
4. Try adding Rs.MoveLast followed by Rs.MoveFirst at the start of yourloop
I added both lines no luck.
I did notice that the oldest ID# in the report gets all records dumped into it. It’s as if the first loop it creates a master (but uses an ID for name) than starts the process for the rest.
isladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
I actually meant which PDF contains all the records.
I think you are saying the first one does....?
Try commenting out repeated qdf items including all 'set qdf =Nothing' lines except the last
Check it still compiles and run it.
If that's not clear, copy and paste the code using the code tag button (#).
Then I'll edit it and post it back
I think you are saying the first one does....?
Try commenting out repeated qdf items including all 'set qdf =Nothing' lines except the last
Check it still compiles and run it.
If that's not clear, copy and paste the code using the code tag button (#).
Then I'll edit it and post it back
Note table name and query do not match original, wanted to clean code for reader/newbie. made changes you suggested and compiled with no issues, code below runs perfect, except the first record gets everything dumped in it. I appreciate you taking the time to help.
Code:
Private Sub Command399_Click()
Dim qdf As DAO.QueryDef
Dim strSQL As String
Dim strPathName As String
Dim blRet As Boolean
Dim rs As Recordset
Dim stDocName As String
Dim file As String
Dim strSavedSQL As String
If Me.Dirty Then Me.Dirty = False
stDocName = "sendtrips"
strSQL = "SELECT tblMasterLogisticare.id FROM tblMasterLogisticare WHERE (((triptaken)=True));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount < 1 Then
MsgBox "Nothing found to process", vbCritical, "Error"
Exit Sub
End If
' store the current SQL
Set qdf = CurrentDb.QueryDefs("sendtrip")
strSavedSQL = qdf.SQL
'qdf.Close
'Set qdf = Nothing
rs.MoveLast
rs.MoveFirst
Do
'Set qdf = CurrentDb.QueryDefs("sendtrip")
strSQL = Left(strSavedSQL, InStr(strSavedSQL, ";") - 1) & " and (tblMasterLogisticare.id = " & rs!id & ") ;"
qdf.SQL = strSQL
'qdf.Close
'Set qdf = Nothing
strPathName = "C:\orders\"
file = Report_Sendtrips![Location name a] & "-" & Report_Sendtrips![AJobnumber] & "-" & rs!id & ".pdf"
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathName & file
rs.MoveNext
Loop Until rs.EOF
rs.Close
Set rs = Nothing
' restore the SQL
'Set qdf = CurrentDb.QueryDefs("sendtrip")
qdf.SQL = strSavedSQL
qdf.Close
Set qdf = Nothing
End Subisladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
Maybe I'm being dense but I can't see what the loop is actually doing with the qdf.sql
The only point of the recordset seems to be to get the ID value for each report filename
Some changes made to further simplify this but I can't picture what's going on
The only point of the recordset seems to be to get the ID value for each report filename
Some changes made to further simplify this but I can't picture what's going on
Code:
Private Sub Command399_Click()[COLOR="Red"] 'recommend using meaningful control names[/COLOR]
Dim qdf As DAO.QueryDef
Dim strSQL As String
Dim strPathName As String
[COLOR="red"]' Dim blRet As Boolean 'NOT USED[/COLOR]
Dim rs As [COLOR="Red"]DAO.[/COLOR]Recordset
Dim stDocName As String
Dim file As String
Dim strSavedSQL As String
If Me.Dirty Then Me.Dirty = False
stDocName = "sendtrips"
strSQL = "SELECT tblMasterLogisticare.id FROM tblMasterLogisticare WHERE (((triptaken)=True));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount < 1 Then
MsgBox "Nothing found to process", vbCritical, "Error"
Exit Sub
End If
' store the current SQL
Set qdf = CurrentDb.QueryDefs("sendtrip")
strSavedSQL = qdf.SQL
rs.MoveLast
rs.MoveFirst
Do Until rs.EOF
[COLOR="red"] 'What do these 2 lines actually do as they don't seem to be used for anything![/COLOR]
[COLOR="Red"] 'Try commenting these out as well[/COLOR]
[COLOR="RoyalBlue"] strSQL = Left(strSavedSQL, InStr(strSavedSQL, ";") - 1) & " And (tblMasterLogisticare.id = " & rs!id & ") ;"
qdf.SQL = strSQL[/COLOR]
strPathName = "C:\orders\"
file = Report_Sendtrips![Location name a] & "-" & Report_Sendtrips![AJobnumber] & "-" & rs!id & ".pdf"
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathName & file
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
[COLOR="red"] ' restore the SQL - NOT NEEDED
'Set qdf = CurrentDb.QueryDefs("sendtrip")
' qdf.SQL = strSavedSQL 'OMIT [/COLOR]
qdf.Close
Set qdf = Nothing
End SubWas able to comment out
and system performed like normal. Tried commenting out lines below.
Outcome was lost file names and all files had same name with all records within.
Example:
123456.pdf size 160kb 40pages
123456.pdf size 160kb 40pages…
I’m going to call it a night and tackle in morning, appreciate all your help.
Code:
“' Dim blRet As Boolean 'NOT USED”
Code:
'What do these 2 lines actually do as they don't seem to be used for anything!
'Try commenting these out as well
strSQL = Left(strSavedSQL, InStr(strSavedSQL, ";") - 1) & " And (tblMasterLogisticare.id = " & rs!id & ") ;"
qdf.SQL = strSQLOutcome was lost file names and all files had same name with all records within.
Example:
123456.pdf size 160kb 40pages
123456.pdf size 160kb 40pages…
I’m going to call it a night and tackle in morning, appreciate all your help.
Cronk
Registered User.
- Local time
- Today, 12:34
- Joined
- Jul 4, 2013
- Messages
- 2,789
Going back to the code with the original post, it looks to me like the data source for the report is the query "QrySendTrip" which supposedly includes all records where a trip has occurred eg
and then the objective is to produce PDFs for each record in the query.
This is achieved by updating the query in each pass through the loop to extend the query's criteria to
This is the way I do it when I want to dynamically change the report's recordsource at run time. (I could never find another way when outputting to PDF format.)
However, there is nothing to see what is stored in strSavedSQL.
I'd suggest adding in the loop
to see what data is actually being fed to the report.
Code:
...WHERE TripTaken = true;"This is achieved by updating the query in each pass through the loop to extend the query's criteria to
Code:
WHERE TripTaken = true and tblTrips!ID=" & rs!IDHowever, there is nothing to see what is stored in strSavedSQL.
I'd suggest adding in the loop
Code:
debug.print qdf.sql
arnelgp
..forever waiting... waiting for jellybean!
- Local time
- Today, 09:34
- Joined
- May 7, 2009
- Messages
- 19,703
Code:
Private Sub Command399_Click()
Dim qdf As DAO.QueryDef
Dim strSQL As String
Dim strPathName As String
Dim blRet As Boolean
Dim rs As Recordset
Dim stDocName As String
Dim file As String
Dim strSavedSQL As String
'* arnelgp
Dim strSelect As String
Dim strWhere As String
Dim strOrderBy As String
Dim strGroupBy As String
Dim strHaving As String
If Me.Dirty Then Me.Dirty = False
stDocName = "sendtrips"
strSQL = "SELECT tblMasterLogisticare.id FROM tblMasterLogisticare WHERE (((triptaken)=True));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount < 1 Then
MsgBox "Nothing found to process", vbCritical, "Error"
Exit Sub
End If
' store the current SQL
Set qdf = CurrentDb.QueryDefs("sendtrip")
strSavedSQL = qdf.SQL
qdf.Close
Set qdf = Nothing
rs.MoveLast
rs.MoveFirst
Do
Set qdf = CurrentDb.QueryDefs("sendtrip")
strSQL = Replace(strSavedSQL, ";", "")
'* init variables
strSelect = vbNullString
strWhere = vbNullString
strOrderBy = vbNullString
strOrderBy = vbNullString
strGroupBy = vbNullString
strHaving = vbNullString
'* parse these values
ParseSQL strSQL, strSelect, strWhere, strOrderBy, strGroupBy, strHaving
'* we have the Where Clause in strWhere
If strWhere <> vbNullString Then
strWhere = strWhere & " And (tblMasterLogisticare.id = " & rs!id & ")"
Else
strWhere = "(tblMasterLogisticare.id = " & rs!id & ")"
End If
'* replace the Where Clause
strSQL = ReplaceWhereClause(strSelect, strWhere)
'strSQL = Left(strSavedSQL, InStr(strSavedSQL, ";") - 1) & " and (tblMasterLogisticare.id = " & rs!id & ") ;"
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
strPathName = "C:\orders\"
file = Report_Sendtrips![Location name a] & "-" & Report_Sendtrips![AJobnumber] & "-" & rs!id & ".pdf"
'* check if file already exists and delete if exists
If Dir(strPathName & file) <> vbnullstring Then Kill (strPathName & file)
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathName & file
rs.MoveNext
Loop Until rs.EOF
rs.Close
Set rs = Nothing
'restore the SQL
Set qdf = CurrentDb.QueryDefs("sendtrip")
qdf.SQL = strSavedSQL
qdf.Close
Set qdf = Nothing
End Subalso copy and paste this code in separate Module:
Code:
Option Compare Database
Option Explicit
'***************************************************************************************
' Module : basSQLParser
' Author : Excerpt from Access 2007 VBA - Programmer's Reference - Wrox WW
' Date :
' Purpose :
'***************************************************************************************
Public Sub ParseSQL(ByVal strSQL As String, _
ByRef strSelect As String, _
ByRef strWhere As String, _
ByRef strOrderBy As String, _
ByRef strGROUPBY As String, _
ByRef strHAVING As String)
On Error GoTo Error_Handler
'
'This subroutine accepts a valid SQL string and passes back separated
'SELECT, WHERE, ORDER BY, and GROUP BY clauses.
'
'INPUT:
' strSQL valid SQL string to parse
'OUTPUT:
' strSELECT SELECT portion of SQL (includes JOIN info)
' strWHERE WHERE portion of SQL
' strORDERBY ORDER BY portion of SQL
' strGROUPBY GROUP BY portion of SQL
' strHAVING HAVING portion of SQL
Dim intStartSELECT As Integer
Dim intStartWHERE As Integer
Dim intStartORDERBY As Integer
Dim intStartGROUPBY As Integer
Dim intStartHAVING As Integer
Dim intLenSELECT As Integer
Dim intLenWHERE As Integer
Dim intLenORDERBY As Integer
Dim intLenGROUPBY As Integer
Dim intLenHAVING As Integer
Dim intLenSQL As Integer
intStartSELECT = InStr(strSQL, "SELECT ")
intStartWHERE = InStr(strSQL, "WHERE ")
intStartORDERBY = InStr(strSQL, "ORDER BY ")
intStartGROUPBY = InStr(strSQL, "GROUP BY ")
intStartHAVING = InStr(strSQL, "HAVING ")
'if there's no GROUP BY, there can't be a HAVING
If intStartGROUPBY = 0 Then
intStartHAVING = 0
End If
If InStr(strSQL, ";") Then 'if it exists, trim off the ';'
strSQL = Left(strSQL, InStr(strSQL, ";") - 1)
End If
intLenSQL = Len(strSQL)
' find length of Select portion
If intStartSELECT > 0 Then
' start with longest it could be
intLenSELECT = intLenSQL - intStartSELECT + 1
If intStartWHERE > 0 And intStartWHERE > intStartSELECT _
And intStartWHERE < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartWHERE - intStartSELECT
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartSELECT _
And intStartORDERBY < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartORDERBY - intStartSELECT
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartSELECT _
And intStartGROUPBY < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartGROUPBY - intStartSELECT
End If
If intStartHAVING > 0 And intStartHAVING > intStartSELECT _
And intStartHAVING < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartHAVING - intStartSELECT
End If
End If
' find length of GROUPBY portion
If intStartGROUPBY > 0 Then
' start with longest it could be
intLenGROUPBY = intLenSQL - intStartGROUPBY + 1
If intStartWHERE > 0 And intStartWHERE > intStartGROUPBY _
And intStartWHERE < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartWHERE - intStartGROUPBY
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartGROUPBY _
And intStartORDERBY < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartORDERBY - intStartGROUPBY
End If
If intStartHAVING > 0 And intStartHAVING > intStartGROUPBY _
And intStartHAVING < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartHAVING - intStartGROUPBY
End If
End If
' find length of HAVING portion
If intStartHAVING > 0 Then
' start with longest it could be
intLenHAVING = intLenSQL - intStartHAVING + 1
If intStartWHERE > 0 And intStartWHERE > intStartHAVING _
And intStartWHERE < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartWHERE - intStartHAVING
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartHAVING _
And intStartORDERBY < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartORDERBY - intStartHAVING
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartHAVING _
And intStartGROUPBY < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartGROUPBY - intStartHAVING
End If
End If
' find length of ORDERBY portion
If intStartORDERBY > 0 Then
' start with longest it could be
intLenORDERBY = intLenSQL - intStartORDERBY + 1
If intStartWHERE > 0 And intStartWHERE > intStartORDERBY _
And intStartWHERE < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartWHERE - intStartORDERBY
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartORDERBY _
And intStartGROUPBY < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartGROUPBY - intStartORDERBY
End If
If intStartHAVING > 0 And intStartHAVING > intStartORDERBY _
And intStartHAVING < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartHAVING - intStartORDERBY
End If
End If
' find length of WHERE portion
If intStartWHERE > 0 Then
' start with longest it could be
intLenWHERE = intLenSQL - intStartWHERE + 1
If intStartGROUPBY > 0 And intStartGROUPBY > intStartWHERE _
And intStartGROUPBY < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartGROUPBY - intStartWHERE
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartWHERE _
And intStartORDERBY < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartORDERBY - intStartWHERE
End If
If intStartHAVING > 0 And intStartHAVING > intStartWHERE _
And intStartHAVING < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartHAVING - intStartWHERE
End If
End If
' set each output portion
If intStartSELECT > 0 Then
strSelect = Mid$(strSQL, intStartSELECT, intLenSELECT)
End If
If intStartGROUPBY > 0 Then
strGROUPBY = Mid$(strSQL, intStartGROUPBY, intLenGROUPBY)
End If
If intStartHAVING > 0 Then
strHAVING = Mid$(strSQL, intStartHAVING, intLenHAVING)
End If
If intStartORDERBY > 0 Then
strOrderBy = Mid$(strSQL, intStartORDERBY, intLenORDERBY)
End If
If intStartWHERE > 0 Then
strWhere = Mid$(strSQL, intStartWHERE, intLenWHERE)
End If
Exit_Procedure:
Exit Sub
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Sub
Public Function ReplaceWhereClause(ByVal strSQL As String, ByVal strNewWHERE As String) As String
On Error GoTo Error_Handler
'This subroutine accepts a valid SQL string and Where clause, and
'returns the same SQL statement with the original Where clause (if any)
'replaced by the passed in Where clause.
'
'INPUT:
' strSQL valid SQL string to change
'OUTPUT:
' strNewWHERE New WHERE clause to insert into SQL statement
'
Dim strSelect As String, strWhere As String
Dim strOrderBy As String, strGROUPBY As String, strHAVING As String
Call ParseSQL(strSQL, strSelect, strWhere, strOrderBy, _
strGROUPBY, strHAVING)
ReplaceWhereClause = BuildSQLString(strSelect, strNewWHERE, strOrderBy, _
strGROUPBY, strHAVING)
Exit_Procedure:
Exit Function
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Function
Public Function ReplaceOrderByClause(ByVal strSQL As String, ByVal strNewOrderBy As String) As String
On Error GoTo Error_Handler
'
'INPUT:
' strSQL valid SQL string to change
'OUTPUT:
' strNewOrderBy New OrderBy clause to insert into SQL statement
'
Dim strSelect As String, strWhere As String
Dim strOrderBy As String, strGROUPBY As String, strHAVING As String
Call ParseSQL(strSQL, strSelect, strWhere, strOrderBy, _
strGROUPBY, strHAVING)
ReplaceOrderByClause = BuildSQLString(strSelect, strWhere, strNewOrderBy, _
strGROUPBY, strHAVING)
Exit_Procedure:
Exit Function
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Function
Private Function BuildSQLString(ByVal strSelect As String, ByVal strWhere As String, ByVal strOrderBy As String, _
ByVal strGROUPBY As String, ByVal strHAVING As String) As String
BuildSQLString = strSelect
If strWhere <> "" Then BuildSQLString = BuildSQLString & " WHERE " & strWhere
If strGROUPBY <> "" Then BuildSQLString = BuildSQLString & " GROUP BY " & strGROUPBY
If strHAVING <> "" Then BuildSQLString = BuildSQLString & " HAVING " & strHAVING
If strOrderBy <> "" Then BuildSQLString = BuildSQLString & " ORDER BY " & strOrderBy
BuildSQLString = Replace(BuildSQLString, " ", " ")
End Functionisladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
Lets try & keep this simple
Building on cronk's idea...I believe this will work
Building on cronk's idea...I believe this will work
Code:
Private Sub Command399_Click() [COLOR="SeaGreen"]'recommend using meaningful control names[/COLOR]
[COLOR="SeaGreen"] 'Dim qdf As DAO.QueryDef 'NO LONGER USED[/COLOR]
Dim strSQL As String
Dim strPathName As String
Dim rs As DAO.Recordset
Dim stDocName As String
Dim strFileName As String
[COLOR="seagreen"] ' Dim strSavedSQL As String 'NO LONGER USED[/COLOR]
If Me.Dirty Then Me.Dirty = False
[COLOR="seagreen"] 'get SQL for recordset
'if all 3 fields aren't in this table, adapt it to create a query from more than one table to include them [/COLOR]
strSQL = "SELECT tblMasterLogisticare.id, tblMasterLogisticare.[Location name a], tblMasterLogisticare.AJobnumber FROM tblMasterLogisticare WHERE (((TripTaken)=True));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount < 1 Then
MsgBox "Nothing found to process", vbCritical, "Error"
Exit Sub
End If
With rs
.MoveLast
.MoveFirst
Do Until .EOF
stDocName = "sendtrips"
strPathName = "C:\orders\"
strFileName = ![Location name a] & "-" & !AJobnumber & "-" & !id & ".pdf"
Debug.Print strFileName[COLOR="seagreen"] 'check output file name[/COLOR]
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathName & strFileName
.MoveNext
Loop
.Close
End With
[COLOR="SeaGreen"] 'clear up[/COLOR]
Set rs = Nothing
End Sub
Last edited:
Thank you everyone for your help, below is the outcome of each suggestion.
Code had same outcome as original.
Unfortunately, nothing helped, I’m going to leave the code as-is or use arnelgp code both produce same outcome. My work around is to leave record #1 named master and use it as a dump file for each run. Thanks again.
Code gave me correct file names but dumped all records in each file.
Code:
Option Compare Database
Option Explicit
'***************************************************************************************
' Module : basSQLParser
' Author : Excerpt from Access 2007 VBA - Programmer's Reference - Wrox WW
' Date :
' Purpose :
'***************************************************************************************
Public Sub ParseSQL(ByVal strSQL As String, _
ByRef strSelect As String, _
ByRef strWhere As String, _
ByRef strOrderBy As String, _
ByRef strGROUPBY As String, _
ByRef strHAVING As String)
On Error GoTo Error_Handler
'
'This subroutine accepts a valid SQL string and passes back separated
'SELECT, WHERE, ORDER BY, and GROUP BY clauses.
'
'INPUT:
' strSQL valid SQL string to parse
'OUTPUT:
' strSELECT SELECT portion of SQL (includes JOIN info)
' strWHERE WHERE portion of SQL
' strORDERBY ORDER BY portion of SQL
' strGROUPBY GROUP BY portion of SQL
' strHAVING HAVING portion of SQL
Dim intStartSELECT As Integer
Dim intStartWHERE As Integer
Dim intStartORDERBY As Integer
Dim intStartGROUPBY As Integer
Dim intStartHAVING As Integer
Dim intLenSELECT As Integer
Dim intLenWHERE As Integer
Dim intLenORDERBY As Integer
Dim intLenGROUPBY As Integer
Dim intLenHAVING As Integer
Dim intLenSQL As Integer
intStartSELECT = InStr(strSQL, "SELECT ")
intStartWHERE = InStr(strSQL, "WHERE ")
intStartORDERBY = InStr(strSQL, "ORDER BY ")
intStartGROUPBY = InStr(strSQL, "GROUP BY ")
intStartHAVING = InStr(strSQL, "HAVING ")
'if there's no GROUP BY, there can't be a HAVING
If intStartGROUPBY = 0 Then
intStartHAVING = 0
End If
If InStr(strSQL, ";") Then 'if it exists, trim off the ';'
strSQL = Left(strSQL, InStr(strSQL, ";") - 1)
End If
intLenSQL = Len(strSQL)
' find length of Select portion
If intStartSELECT > 0 Then
' start with longest it could be
intLenSELECT = intLenSQL - intStartSELECT + 1
If intStartWHERE > 0 And intStartWHERE > intStartSELECT _
And intStartWHERE < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartWHERE - intStartSELECT
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartSELECT _
And intStartORDERBY < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartORDERBY - intStartSELECT
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartSELECT _
And intStartGROUPBY < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartGROUPBY - intStartSELECT
End If
If intStartHAVING > 0 And intStartHAVING > intStartSELECT _
And intStartHAVING < intStartSELECT + intLenSELECT Then
'we found a new portion closer to this one
intLenSELECT = intStartHAVING - intStartSELECT
End If
End If
' find length of GROUPBY portion
If intStartGROUPBY > 0 Then
' start with longest it could be
intLenGROUPBY = intLenSQL - intStartGROUPBY + 1
If intStartWHERE > 0 And intStartWHERE > intStartGROUPBY _
And intStartWHERE < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartWHERE - intStartGROUPBY
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartGROUPBY _
And intStartORDERBY < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartORDERBY - intStartGROUPBY
End If
If intStartHAVING > 0 And intStartHAVING > intStartGROUPBY _
And intStartHAVING < intStartGROUPBY + intLenGROUPBY Then
'we found a new portion closer to this one
intLenGROUPBY = intStartHAVING - intStartGROUPBY
End If
End If
' find length of HAVING portion
If intStartHAVING > 0 Then
' start with longest it could be
intLenHAVING = intLenSQL - intStartHAVING + 1
If intStartWHERE > 0 And intStartWHERE > intStartHAVING _
And intStartWHERE < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartWHERE - intStartHAVING
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartHAVING _
And intStartORDERBY < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartORDERBY - intStartHAVING
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartHAVING _
And intStartGROUPBY < intStartHAVING + intLenHAVING Then
'we found a new portion closer to this one
intLenHAVING = intStartGROUPBY - intStartHAVING
End If
End If
' find length of ORDERBY portion
If intStartORDERBY > 0 Then
' start with longest it could be
intLenORDERBY = intLenSQL - intStartORDERBY + 1
If intStartWHERE > 0 And intStartWHERE > intStartORDERBY _
And intStartWHERE < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartWHERE - intStartORDERBY
End If
If intStartGROUPBY > 0 And intStartGROUPBY > intStartORDERBY _
And intStartGROUPBY < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartGROUPBY - intStartORDERBY
End If
If intStartHAVING > 0 And intStartHAVING > intStartORDERBY _
And intStartHAVING < intStartORDERBY + intLenORDERBY Then
'we found a new portion closer to this one
intLenORDERBY = intStartHAVING - intStartORDERBY
End If
End If
' find length of WHERE portion
If intStartWHERE > 0 Then
' start with longest it could be
intLenWHERE = intLenSQL - intStartWHERE + 1
If intStartGROUPBY > 0 And intStartGROUPBY > intStartWHERE _
And intStartGROUPBY < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartGROUPBY - intStartWHERE
End If
If intStartORDERBY > 0 And intStartORDERBY > intStartWHERE _
And intStartORDERBY < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartORDERBY - intStartWHERE
End If
If intStartHAVING > 0 And intStartHAVING > intStartWHERE _
And intStartHAVING < intStartWHERE + intLenWHERE Then
'we found a new portion closer to this one
intLenWHERE = intStartHAVING - intStartWHERE
End If
End If
' set each output portion
If intStartSELECT > 0 Then
strSelect = Mid$(strSQL, intStartSELECT, intLenSELECT)
End If
If intStartGROUPBY > 0 Then
strGROUPBY = Mid$(strSQL, intStartGROUPBY, intLenGROUPBY)
End If
If intStartHAVING > 0 Then
strHAVING = Mid$(strSQL, intStartHAVING, intLenHAVING)
End If
If intStartORDERBY > 0 Then
strOrderBy = Mid$(strSQL, intStartORDERBY, intLenORDERBY)
End If
If intStartWHERE > 0 Then
strWhere = Mid$(strSQL, intStartWHERE, intLenWHERE)
End If
Exit_Procedure:
Exit Sub
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Sub
Public Function ReplaceWhereClause(ByVal strSQL As String, ByVal strNewWHERE As String) As String
On Error GoTo Error_Handler
'This subroutine accepts a valid SQL string and Where clause, and
'returns the same SQL statement with the original Where clause (if any)
'replaced by the passed in Where clause.
'
'INPUT:
' strSQL valid SQL string to change
'OUTPUT:
' strNewWHERE New WHERE clause to insert into SQL statement
'
Dim strSelect As String, strWhere As String
Dim strOrderBy As String, strGROUPBY As String, strHAVING As String
Call ParseSQL(strSQL, strSelect, strWhere, strOrderBy, _
strGROUPBY, strHAVING)
ReplaceWhereClause = BuildSQLString(strSelect, strNewWHERE, strOrderBy, _
strGROUPBY, strHAVING)
Exit_Procedure:
Exit Function
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Function
Public Function ReplaceOrderByClause(ByVal strSQL As String, ByVal strNewOrderBy As String) As String
On Error GoTo Error_Handler
'
'INPUT:
' strSQL valid SQL string to change
'OUTPUT:
' strNewOrderBy New OrderBy clause to insert into SQL statement
'
Dim strSelect As String, strWhere As String
Dim strOrderBy As String, strGROUPBY As String, strHAVING As String
Call ParseSQL(strSQL, strSelect, strWhere, strOrderBy, _
strGROUPBY, strHAVING)
ReplaceOrderByClause = BuildSQLString(strSelect, strWhere, strNewOrderBy, _
strGROUPBY, strHAVING)
Exit_Procedure:
Exit Function
Error_Handler:
MsgBox (err.Number & ": " & err.Description)
Resume Exit_Procedure
End Function
Private Function BuildSQLString(ByVal strSelect As String, ByVal strWhere As String, ByVal strOrderBy As String, _
ByVal strGROUPBY As String, ByVal strHAVING As String) As String
BuildSQLString = strSelect
If strWhere <> "" Then BuildSQLString = BuildSQLString & " WHERE " & strWhere
If strGROUPBY <> "" Then BuildSQLString = BuildSQLString & " GROUP BY " & strGROUPBY
If strHAVING <> "" Then BuildSQLString = BuildSQLString & " HAVING " & strHAVING
If strOrderBy <> "" Then BuildSQLString = BuildSQLString & " ORDER BY " & strOrderBy
BuildSQLString = Replace(BuildSQLString, " ", " ")
End FunctionUnfortunately, nothing helped, I’m going to leave the code as-is or use arnelgp code both produce same outcome. My work around is to leave record #1 named master and use it as a dump file for each run. Thanks again.
isladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
Suggest you post a stripped down copy of your database for someone to look at. The problem for us is making sense of what the original convoluted code was doing. In other words we need to see what is needed to filter this correctly.
I have spent all day working on this problem, so decided to work backwards and start with the version I know works (part of Northwind DB). When I started this journey, I did some research on approaches and found this DB. Originally, I was using only parts of the code in my db but this morning I figured I integrated my table into the system and my report to see If it would work. It perform as desired, but I’m unable to add field.tripname as part of the filename (unfortunately this is critical).
I’m only working with 1 Table: Orders
Two Querries: invoices and qryfrmselectorderstoprint
one Report: xinvoice
Important note anytime you hit “save selected invoices as separate PDF” and it fails due to code it leaves a criteria in the invoices query that must be cleared before retesting (orderid field). Yes, the orders table is ugly, but unfortunately, we are given an excel spreadsheet daily and must dump into a single table.
Desired outcome
file= C:\XX\Dallas-1-81882.pdf
Thanks for any help.
June7
AWF VIP
- Local time
- , 17:34
- Joined
- Mar 9, 2014
- Messages
- 5,600
Is this intended to be a multi-user database?
So the qdf code is intended to modify the query Invoices which is the report RecordSource.
I tested code and it works perfect. Each report output is for only one OrderID. But there are only 3 records to test with.
So the qdf code is intended to modify the query Invoices which is the report RecordSource.
I tested code and it works perfect. Each report output is for only one OrderID. But there are only 3 records to test with.
Cronk
Registered User.
- Local time
- Today, 12:34
- Joined
- Jul 4, 2013
- Messages
- 2,789
Output from supplied database is fine for me - 2 records selected, 2 pdf's generated, each with one of the records.
I notice that the table, query and report that you cited in your initial post is not in the database supplied.
I notice that the table, query and report that you cited in your initial post is not in the database supplied.
You are correct about original post being different, went back to source db to start from scratch.
Yes the code works, but I’m trying to change the out of the filename to something meaningful.
Currently have output file of 175.pdf want it to be Dallas-1-81882.pdf. it's the same record. don't want orderid.pdf want tripname.pdf
June7
AWF VIP
- Local time
- , 17:34
- Joined
- Mar 9, 2014
- Messages
- 5,600
Following revised code works for me:
Code:
Private Sub cmdSaveAsPDF_Click()
Dim qdf As DAO.QueryDef
Dim strPathName As String
Dim rs As Recordset
Dim stDocName As String
Dim strSavedSQL As String
If Me.Dirty Then Me.Dirty = False
stDocName = "xinvoice"
Set rs = CurrentDb.OpenRecordset("SELECT orderid, tripname FROM Orders WHERE SelectedPrint;", dbOpenSnapshot)
If rs.EOF Then
MsgBox "Nothing found to process", vbCritical, "Error"
Else
CreateFolder CurrentProject.Path & "\orders"
' store the current SQL
Set qdf = CurrentDb.QueryDefs("Invoices")
strSavedSQL = qdf.SQL
While Not rs.EOF
qdf.SQL = Left(strSavedSQL, InStr(strSavedSQL, ";") - 1) & " and (orderid = " & rs!OrderID & ");"
' put in the same folder as the database
strPathName = CurrentProject.Path & "\orders\" & rs!tripname & ".pdf"
DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathName
rs.MoveNext
Wend
' restore the SQL
qdf.SQL = strSavedSQL
qdf.Close
Set qdf = Nothing
End If
rs.Close
Set rs = Nothing
End Sub
Last edited:
isladogs
MVP / VIP
- Local time
- Today, 01:34
- Joined
- Jan 14, 2017
- Messages
- 18,510
I can also confirm that the 'convoluted code' as I call it worked perfectly for me.
I then tried rewriting the code I posted earlier
I was just logging off having tried (and I'm embarrassed to say, failed) to adapt my earlier code to get it working.
Mine ran without error, gets the correct SQL but fails to create the PDFs!
@June7
Then I saw your post & tried it but I'm sorry to report bad news.
It also fails for me:
a) Selected one or more records
Code errors with message No invoices selected.
After clicking the message error 2501 occurs (OutputTo cancelled)
Debug. highlights DoCmd.OutputTo line
b) Deselecting all gives the expected nothing to process message follow up error 3129 Invalid SQL statement ....
Debug highlights qdf.SQL = strSavedSQL near end of sub
I haven't stepped through the code or added error handling to check it
Time to switch off now as its late here
I then tried rewriting the code I posted earlier
I was just logging off having tried (and I'm embarrassed to say, failed) to adapt my earlier code to get it working.
Mine ran without error, gets the correct SQL but fails to create the PDFs!
@June7
Then I saw your post & tried it but I'm sorry to report bad news.
It also fails for me:
a) Selected one or more records
Code errors with message No invoices selected.
After clicking the message error 2501 occurs (OutputTo cancelled)
Debug. highlights DoCmd.OutputTo line
b) Deselecting all gives the expected nothing to process message follow up error 3129 Invalid SQL statement ....
Debug highlights qdf.SQL = strSavedSQL near end of sub
I haven't stepped through the code or added error handling to check it
Time to switch off now as its late here
