none
Problem with queries results in SELECT statement RRS feed

  • Question

  • Hi All,

    I have the following problem with the script below.  The script will create for every name in a table an email, and will run  two access queries based on the name, and attach the results in a file Template_products_v1.xlsx, after that the email is first displayed for confirmation. After the confirmation it will continue with the next name, it will do the same but overwrite the values in file Template_products_v1.xlsx with the results of the next name.

    The issue right now is that after running the script a couple times, it will just start with mixing the selected name although " MsgBox "2" & waarde" and  MsgBox "2" & waarde" are still showing the right name for the query 1 and 2?  After change the file Template name the issue is solved but not for long? 

    Could this be related to the " Temporary files on the hard drive"? or do I need to make the template "Template_products_v1.xlsx" first empty before starting with the next name?

    Any suggestion on how to solve this?  

    Function As_text(cur_text As Variant) As String

      If (Not IsNull(cur_text)) Then

        As_text = "'" & Replace(cur_text, "'", "''") & "'"

      End If

    End Function

    '------------------------------------------------------------

    ' Command50_Click

    '

    '------------------------------------------------------------

    Private Sub Command50_Click()

    Dim day As Integer

    day = Weekday(Date, vbSunday)

    Dim TheDate As Variant

    Dim olApp As Outlook.Application

    Dim toMulti, waarde As String

    Dim mItem As Outlook.MailItem  ' An Outlook Mail item

    Dim dbs As Database

    Dim qdfTemp As QueryDef

    Dim qdfTemp1 As QueryDef

    Dim qdfNew As QueryDef

    Dim originalSql As String

    Dim Identified_name As Recordset

    Dim qdf As DAO.QueryDef

    Dim qdf1 As DAO.QueryDef

    Set dbs = CurrentDb

    Set olApp = CreateObject("Outlook.Application")

    Set mItem = olApp.CreateItem(olMailItem)

    Dim rs  As Recordset

       Set rs = CurrentDb.OpenRecordset("Q200_email_contact_world")

       If rs.RecordCount > 0 Then

       rs.MoveFirst

       Do Until rs.EOF

          With mItem

           'Set olApp = CreateObject("Outlook.Application")

             Set mItem = olApp.CreateItem(olMailItem)

              .BodyFormat = olFormatHTML

              toMulti = rs![Name product manager]

              waarde = toMulti

             

    '********************************************************************************* Query 1 start

              For Each qdf In dbs.QueryDefs

               If qdf.Name = "test" Then

                   dbs.QueryDefs.Delete "test"

                   Exit For

               End If

              Next

              TheDate = Now()

              Set qdfTemp = dbs.CreateQueryDef("test")

               With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                 qdfTemp.SQL = " SELECT * FROM  Identified_name " _

                             & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [country]"

                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test", "C:\Users\John.peacock\Documents\Data-base\ Template_products_v1.xlsx", True, "Data"

               End With

               MsgBox "1" & waarde

    '********************************************************************************* Query 1 end

    '********************************************************************************* Query 2 start

              For Each qdf1 In dbs.QueryDefs

              If qdf1.Name = "test1" Then

                   dbs.QueryDefs.Delete "test1"

                   Exit For

              End If

              Next

              Set qdfTemp1 = dbs.CreateQueryDef("test1")

              MsgBox " Selected Product manager : " & waarde

              With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                qdfTemp1.SQL = " SELECT * FROM  Identified_name_products" _

                            & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [Country name],[Nupcode], [Product code(12)]"

               DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test1", "C:\Users\John.peacock\Documents\Data-base\ Template_products_v1.xlsx", True, "Data_products"

              End With

           MsgBox "2" & waarde

              '********************************************************************************* Query 2 end

              .To = "koekoek"

              .CC = ""

              .Subject = "Product providers date - (" & WeekdayName(day) & " - " & Date & ")" & " - " & waarde

                 strbody = "Hi All,<br><br>" & _

                        "<br>" & _

                        "<br>" & _

                        "Regards,<br>" & _

                        "<br>" & _

                        "Anri"

              .HTMLBody = strbody & "<br>" & .HTMLBody

              .Display

              .Attachments.Add ("C:\Users\John.peacock\Documents\Data-base\Template_products_v1.xlsx")

              waarde = ""

      End With

        rs.MoveNext

    Loop

        Else

              MsgBox "No email address!"

        End If

        'olApp.Quit

         Set olApp = Nothing

        Exit Sub

    End Sub


    Anri

    Wednesday, May 4, 2016 3:13 PM

Answers

  • Hi Deepak, Imd, Peter, 

    Excellent feedback with your suggestions!!

    I have it working now below the full script. The script has the following functionality, for each name in a table it will produce an email with a message and will include in a file the results of two queries.  The original tests, running the script  a couple times based on three names provided to be unreliable, as it mixed the names in the query results.  So due to this issue with the select statement I have extended the logic with the following steps below.


    Step 1copy template v1 results to template v2

    step 2 delete rows in the worksheets used for the query results

    Step 3 delete Template v2 completly

    Step 4  Continue with the next name in the table 

    *********************************************

    Below the working script!!!!

    Function As_text(cur_text As Variant) As String

      If (Not IsNull(cur_text)) Then

        As_text = "'" & Replace(cur_text, "'", "''") & "'"

      End If

    End Function

     

     

    '------------------------------------------------------------

    ' Command50_Click

    '

    '------------------------------------------------------------

    Private Sub Command50_Click()

    Dim day As Integer

    day = Weekday(Date, vbSunday)

    Dim FSO

    Dim sFile As String

    Dim TheDate As Variant

    Dim olApp As Outlook.Application

    Dim toMulti, waarde As String

    Dim mItem As Outlook.MailItem  ' An Outlook Mail item

    Dim dbs As Database

    Dim qdfTemp As QueryDef

    Dim qdfTemp1 As QueryDef

    Dim qdfNew As QueryDef

    Dim originalSql As String

    Dim Identified_name As Recordset

    Dim qdf As DAO.QueryDef

    Dim qdf1 As DAO.QueryDef

    Dim wkb As Workbook

    Set dbs = CurrentDb

    Set olApp = CreateObject("Outlook.Application")

    Set mItem = olApp.CreateItem(olMailItem)

    Dim rs  As Recordset

       Set rs = CurrentDb.OpenRecordset("Q200_email_contact_world")

       If rs.RecordCount > 0 Then

       rs.MoveFirst

       Do Until rs.EOF

          With mItem

           'Set olApp = CreateObject("Outlook.Application")

             Set mItem = olApp.CreateItem(olMailItem)

              .BodyFormat = olFormatHTML

              toMulti = rs![Name product manager]

              waarde = toMulti

              

    '********************************************************************************* Query 1 start

              For Each qdf In dbs.QueryDefs

               If qdf.Name = "test" Then

                   dbs.QueryDefs.Delete "test"

                   Exit For

               End If

              Next

              TheDate = Now()

              Set qdfTemp = dbs.CreateQueryDef("test")

               With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                 qdfTemp.SQL = " SELECT * FROM  Identified_name " _

                             & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [country]"

                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", True, "Data"

               End With

               'MsgBox "1" & waarde

    '********************************************************************************* Query 1 end

    '********************************************************************************* Query 2 start

              For Each qdf1 In dbs.QueryDefs

              If qdf1.Name = "test1" Then

                   dbs.QueryDefs.Delete "test1"

                   Exit For

              End If

              Next

              Set qdfTemp1 = dbs.CreateQueryDef("test1")

              MsgBox " Selected product manager : " & waarde

              With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                qdfTemp1.SQL = " SELECT * FROM  Identified_name_products" _

                            & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [Country name],[Nupcode], [Product code(12)]"

               DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test1", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", True, "Data_products"

              End With

              '********************************************************************************* Query 2 end

              .To = toMulti

              .CC = ""

              .Subject = "PTT providers date - (" & WeekdayName(day) & " - " & Date & ")" & " - " & waarde

                 strbody = "Hi All,<br><br>" & _

                        "<B>Please check out the new simplified template <font face=""Times New Roman"" size=""3"" color=""blue""><I>'Template_Product_providers_v1.xlsx'</I></Font> with International </B>" & _

                        "<br>" & _

                        "<br>" & _

                        

                      

                        "Regards,<br>" & _

                        "<br>" & _

                        "Kevin"

              .HTMLBody = strbody & "<br>" & .HTMLBody

              .Display

    ‘******************************begin Copy Query template to new template v2

              FileCopy "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx"

    ‘******************************end Copy Query template to new template v2

     

    ‘***********************************Clean working template begin

     

              Set wkb = Workbooks.Open("C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx")

              wkb.Sheets("Data").Range("A2:E300").ClearContents

              wkb.Sheets("Data_products").Range("A2:M300").ClearContents

              wkb.Close SaveChanges:=True

    ‘***********************************Clean working template end

     

               .Attachments.Add ("C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx")

              waarde = ""

      End With

      '*************************************************** begin delete template v2

      sFile = "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx"

      Set FSO = CreateObject("scripting.FileSystemObject")

      If FSO.FileExists(sFile) Then

          FSO.DeleteFile sFile, True

      Else

        MsgBox " File not found"

      End If

       '*************************************************** end delete template v2

     

      

        rs.MoveNext

    Loop

        Else

              MsgBox "No email address!"

        End If

        'olApp.Quit

         Set olApp = Nothing

        Exit Sub

    End Sub


    Anri



    • Edited by Anri2018 Saturday, May 7, 2016 11:59 AM
    • Marked as answer by Anri2018 Saturday, May 7, 2016 11:59 AM
    Saturday, May 7, 2016 11:53 AM

All replies

  • Hi Anri. I would suggest just deleting the file altogether after the email is sent.

    For example, you could use:

    Kill "C:\Users\John.peacock\Documents\Data-base\Template_products_v1.xlsx"

    Hope that helps...

    • Edited by .theDBguy Wednesday, May 4, 2016 3:59 PM
    Wednesday, May 4, 2016 3:58 PM
  • Hi Anri2018,

    I try to test your code on my side.

    so I also use a queries like you to generate the data.

    but I did not find anything wrong here.

    the all data of the table are exported to the Excel everytime.

    it overwrites everytime.

    here something I did not understand. you have mentioned that "The issue right now is that after running the script a couple times, it will just start with mixing the selected name although ".

    when I run the script it run for all the data and not even a single time data get mixed.

    However the suggestion given by the DB guy can work for you here.

    you can delete the file after sending the mail. it can solve your issue.

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, May 5, 2016 3:55 AM
    Moderator
  • Hi 

    When I run the script for 3 names a couple times it will start mixing names, when I look in the Temporary files on the hard drive I see file "Template_products_v1.xlsx" several time  with (2).xlsx  ....(8).xlsx on the end. 

    I have tried the suggestion and it works fine see the last part of the script below.  The downside of this approach is that I am losing the colours and format of my headers in the template "Template_products_v1.xlsx", that's why I wanted to overwrite the template every time with a new name.  

    Any other suggestions?

    Whould it help Not to delete a file completely, but delete the cell values only so I have still the colours and hearders in the template?  I thinking of the command "Range("A2:F1000").clearContents" will this work in vba or do I need to define it first? 

    Script with delete function <  This works now>

    sFile = "C:\Users\John.peacock\Documents\Data-base\ Template_PTT_providers_v2.xlsx"

      Set FSO = CreateObject("scripting.FileSystemObject")

      If FSO.FileExists(sFile) Then

          FSO.DeleteFile sFile, True

      Else

        MsgBox " File not found"

      End If

       '***************************************************delete file

        rs.MoveNext

    Loop

        Else

              MsgBox "No email address!"

        End If

        'olApp.Quit

         Set olApp = Nothing

        Exit Sub

    End Sub


    Anri

    Thursday, May 5, 2016 10:51 AM
  • Whould it be possible to provide in the command "DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml ....." the format of the header of each column based on text colour and background colour?



    Anri

    Thursday, May 5, 2016 12:15 PM
  • I have tried the suggestion and it works fine see the last part of the script below.  The downside of this approach is that I am losing the colours and format of my headers in the template "Template_products_v1.xlsx", that's why I wanted to overwrite the template every time with a new name.   

    Any other suggestions?

    Hi Anri,

    You could first copy the template to a working version. Fill this working version with the data, and finally after all thing are done, delete this working version.

    Imb.

    Thursday, May 5, 2016 4:14 PM
  • HI Imb,

    I copy now the whole file to a new excel file and delete the file after that. It's creating the same problem when you run the script several times mixing names. Just thinking after the  "FileCopy " ........command can I some how delete or clear cells in the file "Template_Product_providers_v1.xlsx " and specified worksheet "data" cells A2: E1000 and in worksheet "Data_products" cells A2:M1000?  What kind of command can I use for this?  Any suggestions as the file is closed?

    FileCopy " C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx ", " C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx "

              .Attachments.Add ("C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx)

              waarde = ""

      End With

      '***************************************************delete file

      sFile = " C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx "

      Set FSO = CreateObject("scripting.FileSystemObject")

      If FSO.FileExists(sFile) Then

          FSO.DeleteFile sFile, True

      Else

        MsgBox " File not found"

      End If

       '***************************************************delete file

      

        rs.MoveNext

    Loop

        Else

              MsgBox "No email address!"

        End If

        'olApp.Quit

         Set olApp = Nothing

        Exit Sub

    End Sub


    Anri

    Thursday, May 5, 2016 5:04 PM
  • I copy now the whole file to a new excel file and delete the file after that. It's creating the same problem when you run the script several times mixing names. Just thinking after the  "FileCopy " ........command can I some how delete or clear cells in the file "Template_Product_providers_v1.xlsx " and specified worksheet "data" cells A2: E1000 and in worksheet "Data_products" cells A2:M1000?  What kind of command can I use for this?  Any suggestions as the file is closed?

    Hi Anri,

    Alas, I have no experience with Excel programming.

    Very seldom I make an output for Excel, but that is in csv format.

    Imb.

    Thursday, May 5, 2016 8:01 PM
  • Hi Anri2018,

    you have asked above, "can I some how delete or clear cells in the file "Template_Product_providers_v1.xlsx " and specified worksheet "data" cells A2: E1000 and in worksheet "Data_products" cells A2:M1000?  What kind of command can I use for this?  Any suggestions as the file is closed? "

    you can use following line of code if the file is close.

    Workbooks.Open "C:\Users\v-padee\Desktop\Book2.xlsm"
    Sheets("Sheet1").Cells.ClearContents

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, May 6, 2016 12:44 AM
    Moderator
  • Hi Deepak,

    I have created the code for the excel worksheets but something is wrong, as the script thinks the file "Template_Product_providers_v1.xlsx " is still open?

     I defined the workbook with "Dim wkb As Workbook"

                                  

     Set wkb = Workbooks.Open("C:\Users\John.peacock\Documents\Data-base\ Template_Product_providers_v1.xlsx ")   ‘*Open file to clear

    Sheets("Data").Range("A2:E300").ClearContents    ‘*Clear content in worksheet “Data"

    Sheets("Data_products").Range("A2:M300").ClearContents  ‘*Clear content in worksheet “Data_products”

    Workbooks("C:\Users\ John.peacock\Documents\Data-base \Template_Product_providers_v1.xlsx").Close SaveChanges:=True ‘*Close file to clear 

    Application.Quit

    I have tried it as well with the code below?  should I use Exit instead of Quit  maybe? 

    ActiveWorkbook.Sheets("Data").Range("A2:E300").ClearContents

    ActiveWorkbook.Sheets("Data_products").Range("A2:M300").ClearContents

    ActiveWorkbook.Close SaveChanges:=True    ‘*****************Open file to clear

    Application.Quit

    I suggestion on what kind of mistake I make here?


    Anri

    Friday, May 6, 2016 3:45 PM
  • Hi, 

    I went away from is null in case of several issues..

    try to use If len(trim(nz(me.field)))°0 instead...

    Greets

    Peter

    Friday, May 6, 2016 6:56 PM
  • Hi Deepak, Imd, Peter, 

    Excellent feedback with your suggestions!!

    I have it working now below the full script. The script has the following functionality, for each name in a table it will produce an email with a message and will include in a file the results of two queries.  The original tests, running the script  a couple times based on three names provided to be unreliable, as it mixed the names in the query results.  So due to this issue with the select statement I have extended the logic with the following steps below.


    Step 1copy template v1 results to template v2

    step 2 delete rows in the worksheets used for the query results

    Step 3 delete Template v2 completly

    Step 4  Continue with the next name in the table 

    *********************************************

    Below the working script!!!!

    Function As_text(cur_text As Variant) As String

      If (Not IsNull(cur_text)) Then

        As_text = "'" & Replace(cur_text, "'", "''") & "'"

      End If

    End Function

     

     

    '------------------------------------------------------------

    ' Command50_Click

    '

    '------------------------------------------------------------

    Private Sub Command50_Click()

    Dim day As Integer

    day = Weekday(Date, vbSunday)

    Dim FSO

    Dim sFile As String

    Dim TheDate As Variant

    Dim olApp As Outlook.Application

    Dim toMulti, waarde As String

    Dim mItem As Outlook.MailItem  ' An Outlook Mail item

    Dim dbs As Database

    Dim qdfTemp As QueryDef

    Dim qdfTemp1 As QueryDef

    Dim qdfNew As QueryDef

    Dim originalSql As String

    Dim Identified_name As Recordset

    Dim qdf As DAO.QueryDef

    Dim qdf1 As DAO.QueryDef

    Dim wkb As Workbook

    Set dbs = CurrentDb

    Set olApp = CreateObject("Outlook.Application")

    Set mItem = olApp.CreateItem(olMailItem)

    Dim rs  As Recordset

       Set rs = CurrentDb.OpenRecordset("Q200_email_contact_world")

       If rs.RecordCount > 0 Then

       rs.MoveFirst

       Do Until rs.EOF

          With mItem

           'Set olApp = CreateObject("Outlook.Application")

             Set mItem = olApp.CreateItem(olMailItem)

              .BodyFormat = olFormatHTML

              toMulti = rs![Name product manager]

              waarde = toMulti

              

    '********************************************************************************* Query 1 start

              For Each qdf In dbs.QueryDefs

               If qdf.Name = "test" Then

                   dbs.QueryDefs.Delete "test"

                   Exit For

               End If

              Next

              TheDate = Now()

              Set qdfTemp = dbs.CreateQueryDef("test")

               With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                 qdfTemp.SQL = " SELECT * FROM  Identified_name " _

                             & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [country]"

                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", True, "Data"

               End With

               'MsgBox "1" & waarde

    '********************************************************************************* Query 1 end

    '********************************************************************************* Query 2 start

              For Each qdf1 In dbs.QueryDefs

              If qdf1.Name = "test1" Then

                   dbs.QueryDefs.Delete "test1"

                   Exit For

              End If

              Next

              Set qdfTemp1 = dbs.CreateQueryDef("test1")

              MsgBox " Selected product manager : " & waarde

              With dbs

                  'Run query on selected Name product manager with value 'No Std products available'

                qdfTemp1.SQL = " SELECT * FROM  Identified_name_products" _

                            & " WHERE [Name product manager] = " & As_text(waarde) _

                             & " ORDER BY [Country name],[Nupcode], [Product code(12)]"

               DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "test1", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", True, "Data_products"

              End With

              '********************************************************************************* Query 2 end

              .To = toMulti

              .CC = ""

              .Subject = "PTT providers date - (" & WeekdayName(day) & " - " & Date & ")" & " - " & waarde

                 strbody = "Hi All,<br><br>" & _

                        "<B>Please check out the new simplified template <font face=""Times New Roman"" size=""3"" color=""blue""><I>'Template_Product_providers_v1.xlsx'</I></Font> with International </B>" & _

                        "<br>" & _

                        "<br>" & _

                        

                      

                        "Regards,<br>" & _

                        "<br>" & _

                        "Kevin"

              .HTMLBody = strbody & "<br>" & .HTMLBody

              .Display

    ‘******************************begin Copy Query template to new template v2

              FileCopy "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx", "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx"

    ‘******************************end Copy Query template to new template v2

     

    ‘***********************************Clean working template begin

     

              Set wkb = Workbooks.Open("C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v1.xlsx")

              wkb.Sheets("Data").Range("A2:E300").ClearContents

              wkb.Sheets("Data_products").Range("A2:M300").ClearContents

              wkb.Close SaveChanges:=True

    ‘***********************************Clean working template end

     

               .Attachments.Add ("C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx")

              waarde = ""

      End With

      '*************************************************** begin delete template v2

      sFile = "C:\Users\John.peacock\Documents\Data-base\Template_Product_providers_v2.xlsx"

      Set FSO = CreateObject("scripting.FileSystemObject")

      If FSO.FileExists(sFile) Then

          FSO.DeleteFile sFile, True

      Else

        MsgBox " File not found"

      End If

       '*************************************************** end delete template v2

     

      

        rs.MoveNext

    Loop

        Else

              MsgBox "No email address!"

        End If

        'olApp.Quit

         Set olApp = Nothing

        Exit Sub

    End Sub


    Anri



    • Edited by Anri2018 Saturday, May 7, 2016 11:59 AM
    • Marked as answer by Anri2018 Saturday, May 7, 2016 11:59 AM
    Saturday, May 7, 2016 11:53 AM