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
