Hi all,
You have assisted in the past to code my email option
I now had to amend as there are new recipients I need to add
The new ecipients are from MaterialPlanner group, there are 2 recipients
It nw seems that the code looks at these 2 lines and there are the 2 current user email entries and the code gives error on the authentication
So what I did was amend the GMailSettingQry to host the sender email address and removing the sender email (currentusermail) from the qry EmailTBLQry_NewDaw
I am having issue to recode
Please could you assist?
You have assisted in the past to code my email option
I now had to amend as there are new recipients I need to add
The new ecipients are from MaterialPlanner group, there are 2 recipients
It nw seems that the code looks at these 2 lines and there are the 2 current user email entries and the code gives error on the authentication
So what I did was amend the GMailSettingQry to host the sender email address and removing the sender email (currentusermail) from the qry EmailTBLQry_NewDaw
I am having issue to recode
Please could you assist?
Option Compare Database
Option Explicit
Dim StrFileName As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aMaterialPlannerMail As String
Dim aCurrentUserMail As String
Dim scc As String
Dim vRecipientList As String
Dim vRecipientListFrom As String
Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
'Check Gmail Settings
If Nz(DLookup("[EmailType]", "[GMailSettingsQry]")) = "" Then
DoCmd.SetWarnings False
DoCmd.OpenQuery "Clear Email Setting Tbl Local"
DoCmd.OpenQuery "Update Email Setting Tbl Local"
DoCmd.SetWarnings True
Exit Sub
End If
'Enter Password
If Nz(DLookup("[WPass]", "[GMailSettingsQry]")) = "" Then
DoCmd.SetWarnings False
DoCmd.OpenQuery "Delete blank Entries - DAW Status", acViewNormal, acEdit
DoCmd.OpenQuery "Clear_Registration_File", acViewNormal, acEdit
DoCmd.OpenQuery "Update_Registration_All", acViewNormal, acEdit
DoCmd.OpenForm "Airbus Mail Frm - New DAW"
DoCmd.SetWarnings True
Exit Sub
' Dim Message As String, Title As String, Default As String
' Message = "Enter Windows Password"
' Title = "Enter Parameters"
' WPassStr = InputBoxDK(Message, Title) '(* Password)
' If WPassStr = "" Then MsgBox "You did not enter a password.", vbCritical: Exit Sub
' DoCmd.SetWarnings False
' DoCmd.RunSQL "UPDATE GMailSettingsQry SET WPass =""" & WPassStr & """"
End If
Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String
'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
'Obtain the email address for the current user email - "From" email
Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry; ")
If rss.RecordCount > 0 Then
rss.MoveFirst
Do
'Set To Recipient
If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
If Not IsNull(rss!To) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
'Set CC Recipient
If Not IsNull(rs!ProjectLeaderMail) And rs!ProjectLeaderMail <> "N/A" Then aProjectLeaderMail = aProjectLeaderMail & rs("ProjectLeaderMail") & ","
If Not IsNull(rs!ProductionPlannerMail) And rs!ProductionPlannerMail <> "N/A" Then aProductionPlannerMail = aProductionPlannerMail & rs("ProductionPlannerMail") & ","
If Not IsNull(rs!MaterialPlannerMail) And rs!MaterialPlannerMail <> "N/A" Then aMaterialPlannerMail = aMaterialPlannerMail & rs("MaterialPlannerMail") & ","
If Not IsNull(rs!CurrentUserMail) And rs!CurrentUserMail <> "N/A" Then aCurrentUserMail = aCurrentUserMail & rs("CurrentUserMail") & ","
If aProjectLeaderMail <> aProductionPlannerMail Then
scc = scc & aProjectLeaderMail & "," & aProductionPlannerMail & ","
If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
scc = scc & "," & aCurrentUserMail & ","
End If
Else
scc = scc & aProjectLeaderMail & ","
If aCurrentUserMail <> aProductionPlannerMail Then
scc = scc & "," & aCurrentUserMail & ","
End If
End If
rs.MoveNext
Loop Until rs.EOF
'vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration")
vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
'vSubject = "DAW Sheet Approved - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_QualityToPlanner]") & " " & ", DAW Sheet" & " " & DLookup("[Daw No]", "[EmailTblQry_QualityToPlanner]")
vReportPDF = CurrentProject.Path & "\" & "DAW Sheet.pdf"
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
DoCmd.OutputTo acReport, "DAW Sheet", acFormatPDF, vReportPDF
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'MsgBox ("Report successfully eMailed!")
Debug.Print aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail, aMaterialPlannerMail
'Debug.Print sCC
'Debug.Print vRecipientList
Debug.Print vRecipientListFrom
'Debug.Print aCurrentUserMail
'Debug.Print DawNo
Else
MsgBox "No contacts."
End If
End If
End Sub