email (1 Viewer)

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
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?

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
 

The_Doc_Man

Immoderate Moderator
Staff member
Local time
Today, 11:19
Joined
Feb 28, 2001
Messages
22,832
These old eyes may not work as well as they used to, but I THINK it might be simply that when adding multiple recipients, you need to add a tiny bit of punctuation. The standard method is to put a semicolon and space ("; ") between each recipient. That is what the SMTP standard suggests.

Like

Code:
If RecipientList = "" Then
    RecipientList = NextRecipient
Else
    RecipientList = RecipientList & "; " & NextRecipient
End If

Something similar to this. You do it this way because you don't want to leave a "; " at the end of the list. You would get an error "Missing recipient" or something similar from your mail-sending function. The same would be true for TO and CC and BCC lists. All use the same standard.
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
These old eyes may not work as well as they used to, but I THINK it might be simply that when adding multiple recipients, you need to add a tiny bit of punctuation. The standard method is to put a semicolon and space ("; ") between each recipient. That is what the SMTP standard suggests.

Like

Code:
If RecipientList = "" Then
    RecipientList = NextRecipient
Else
    RecipientList = RecipientList & "; " & NextRecipient
End If

Something similar to this. You do it this way because you don't want to leave a "; " at the end of the list. You would get an error "Missing recipient" or something similar from your mail-sending function. The same would be true for TO and CC and BCC lists. All use the same standard.
I moved the From to another query where I only have 1 email address

not sure how to close off the loop with the additional Do statement though

Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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

'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.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 Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 17:19
Joined
Sep 21, 2011
Messages
10,574
These old eyes may not work as well as they used to, but I THINK it might be simply that when adding multiple recipients, you need to add a tiny bit of punctuation. The standard method is to put a semicolon and space ("; ") between each recipient. That is what the SMTP standard suggests.

Like

Code:
If RecipientList = "" Then
    RecipientList = NextRecipient
Else
    RecipientList = RecipientList & "; " & NextRecipient
End If

Something similar to this. You do it this way because you don't want to leave a "; " at the end of the list. You would get an error "Missing recipient" or something similar from your mail-sending function. The same would be true for TO and CC and BCC lists. All use the same standard.
I have never had that issue with outlook, so worth trying perhaps, else add the line of code to strip it off.
 

Gasman

Enthusiastic Amateur
Local time
Today, 17:19
Joined
Sep 21, 2011
Messages
10,574
I cannot even read that without indentation.:(
How do you manage to do so?
No need for code tags if your code is like that. :)
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
I cannot even read that without indentation.:(
How do you manage to do so?
No need for code tags if your code is like that. :)
Not sure why the code was pasted without indentation

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 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

'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.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: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")

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 Sub
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
The indentation pasts correct but reformatted to no indentation when posted
 

Gasman

Enthusiastic Amateur
Local time
Today, 17:19
Joined
Sep 21, 2011
Messages
10,574
Are you using code tags? General?
I am on my phone and cannot test.

You are using commas not semicolons as seperaters.

Edit: I see from this thread of yours, that Vlad said you would need to use commas. :(
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 17:19
Joined
Sep 21, 2011
Messages
10,574
Here is my attempt at indentation
Code:
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 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

            'Obtain all the cc addresses
            Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
            If rs.RecordCount > 0 Then
                rs.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: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")

                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 Sub

NB I never use the code tag icons, just enter [ code ] without the spaces and [ /code ] at the end.
There is also the Preview button?

I would say you are missing at least one End If for the first recordcount check?
 
Last edited:

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
Here is my attempt at indetation
Code:
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 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

            'Obtain all the cc addresses
            Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
            If rs.RecordCount > 0 Then
                rs.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: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")

                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 Sub

NB I never use the code tag icons, just enter [ code ] without the spaces and [ /code ] at the end.
There is also the Preview button?

I would say you are missing at least one End If for the first recordcount check?
Yes I need an End if
Not sure where to place it
Below the If statements or just before the End Sub

Both are giving errors
also getting a Do without loop error

If i add the end if above end sub, i get a end if without block if, which i recon should not be in this position
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
Are you using code tags? General?
I am on my phone and cannot test.

You are using commas not semicolons as seperaters.

Edit: I see from this thread of yours, that Vlad said you would need to use commas. :(
Yes, 1i need to use commas, but I moved the current user mail to a different query so I would nou have duplicates on the from email address, the other query has all the recipients

Had a look at the commas
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
Here is my latest attempt

Indentation updated, still no indentation when posting

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
End If


' 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 & """"


Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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

'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do

1649766660969.png

'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: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 Sub
 

bastanu

AWF VIP
Local time
Today, 09:19
Joined
Apr 13, 2010
Messages
1,174
It means the collection (in this case the rss recordset) does not have a field called To which means the GmailSettingsQry does not have that field.

Cheers,
 

bastanu

AWF VIP
Local time
Today, 09:19
Joined
Apr 13, 2010
Messages
1,174
@Gizmo,
Please try this updated version and pay attention to the comments:
Code:
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
End If


' 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 & """"


Dim rs As DAO.Recordset
Dim rss As DAO.Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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 Until rss.EOF    'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
    If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
    'vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
    
    'Obtain all the cc addresses
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
    If rs.RecordCount > 0 Then   
        rs.MoveFirst
        Do until rs.EOF 'Vlad - makes it easier to follow to code       
            'Set To Recipient
            If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
            

            '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") & "," 'Vlad -you said you removed it from this query

            If aProjectLeaderMail <> aProductionPlannerMail Then     
                scc = scc & aProjectLeaderMail & "," & aProductionPlannerMail & ","           
            Else
                scc = scc & aProjectLeaderMail & ","
            End If
            If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
                scc = scc & "," & aCurrentUserMail & ","
            End If

        rs.MoveNext
        Loop 'Until rs.EOF -moved to start of loop


vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 17:19
Joined
Sep 21, 2011
Messages
10,574
Why not also strip out the N/A in the recordset sql, then you do not need to test for it?
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
@Gizmo,
Please try this updated version and pay attention to the comments:
Code:
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
End If


' 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 & """"


Dim rs As DAO.Recordset
Dim rss As DAO.Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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 Until rss.EOF    'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
    If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
    'vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
   
    'Obtain all the cc addresses
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
    If rs.RecordCount > 0 Then  
        rs.MoveFirst
        Do until rs.EOF 'Vlad - makes it easier to follow to code      
            'Set To Recipient
            If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
           

            '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") & "," 'Vlad -you said you removed it from this query

            If aProjectLeaderMail <> aProductionPlannerMail Then    
                scc = scc & aProjectLeaderMail & "," & aProductionPlannerMail & ","          
            Else
                scc = scc & aProjectLeaderMail & ","
            End If
            If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
                scc = scc & "," & aCurrentUserMail & ","
            End If

        rs.MoveNext
        Loop 'Until rs.EOF -moved to start of loop


vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 Sub
Hi,

Below is the SendEmailCDO
I also changed rs to rss as I have moved the controls to a different query to only display a single line
Yes, the vRecipientListFrom is from this code

Sub SendEMailCDO(aTo, acc, aSubject, aTextBody, aFrom, aPath)


Dim rss As Recordset
aFrom = vRecipientListFrom

'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachments
'Date: 25/08/2007
'==========================================


'Dim CDOEmailType As String
Dim txtSendUsing As String
Dim txtPort As String
Dim txtServer As String
Dim txtAuthenticate As String
Dim intTimeOut As String
Dim txtSSL As String
Dim txtusername As String
Dim txtPassword As String
Dim VWPass As String

Dim txtFrom As String

scc = acc

Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry;")
VWPass = VWPass & rss!WPass


'CDOEmailType = rss!EmailType
txtSendUsing = rss!SendUsing
txtPort = rss!ServerPort
txtServer = rss!EmailServer
txtAuthenticate = rss!SMTPAuthenticate
intTimeOut = rss!Timeout
txtusername = GetUserName
txtPassword = VWPass
txtSSL = rss!UseSSL

'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword

On Error GoTo err_SendEMailCDO

Const CdoBodyFormatText = 1
Const CdoBodyFormatHTML = 0
Const CdoMailFormatMime = 0
Const CdoMailFormatText = 1

Dim Message As Object
'Create CDO message object
Set Message = CreateObject("cdo.Message")
With Message.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = txtSendUsing
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = txtPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = txtServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = txtAuthenticate
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = txtusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = txtPassword
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = intTimeOut
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = txtSSL

'code for STARTTLS
If txtPort = 587 Then
.Item("http://schemas.microsoft.com/cdo/configuration/sendtls").Value = True
End If
.Update

End With

DoCmd.Hourglass False

With Message
.To = aTo 'Set email adress
'.CC = aCurrentUserMail
.Subject = aSubject 'Set subject
.TextBody = aTextBody 'Set body text
If Len(acc) > 0 Then .CC = acc 'Set copy to
If Len(aFrom) > 0 Then .From = aFrom 'Set sender address if specified.
If Len(aPath) > 0 Then .AddAttachment (aPath) 'Attach this file
.Send 'Send the message

End With


'Debug lines
'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword, VWPass
'Debug.Print aTo, aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print aTo
'Debug.Print aCurrentUserMail
'Debug.Print sCC
'Debug.Print vRecipientList
'Debug.Print aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"
DoCmd.SetWarnings False
'DoCmd.RunMacro "New DAW Email List"
'DoCmd.OpenQuery "Update Material Data File - SAP number with Material No"
DoCmd.Close acForm, "New DAW Sheet - Create Listing"
DoCmd.Close acForm, "Menu"
DoCmd.OpenForm "Menu"
DoCmd.SetWarnings True

'Clean up
Set Message = Nothing

Exit_SendEMailCDO:

Exit Sub

err_SendEMailCDO:
'MsgBox "Error # " & Str(Err.Number) & Chr(13) & Err.Description

strMsg = "Sorry - I was unable to send the email message(s). " & vbNewLine & vbNewLine & _
"Error # " & Str(Err.Number) & Chr(13) & Err.Description
DoCmd.Hourglass False


MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""


Resume Exit_SendEMailCDO


End Sub
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
@Gizmo,
Please try this updated version and pay attention to the comments:
Code:
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
End If


' 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 & """"


Dim rs As DAO.Recordset
Dim rss As DAO.Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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 Until rss.EOF    'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
    If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
    'vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
   
    'Obtain all the cc addresses
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
    If rs.RecordCount > 0 Then  
        rs.MoveFirst
        Do until rs.EOF 'Vlad - makes it easier to follow to code      
            'Set To Recipient
            If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
           

            '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") & "," 'Vlad -you said you removed it from this query

            If aProjectLeaderMail <> aProductionPlannerMail Then    
                scc = scc & aProjectLeaderMail & "," & aProductionPlannerMail & ","          
            Else
                scc = scc & aProjectLeaderMail & ","
            End If
            If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
                scc = scc & "," & aCurrentUserMail & ","
            End If

        rs.MoveNext
        Loop 'Until rs.EOF -moved to start of loop


vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 Sub
I made the changes as advised but still getting a Do without loop error

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
End If


' 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 & """"


Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'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 Until rss.EOF 'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
'vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF




'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF




'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 & ","
Else
scc = scc & "," & aCurrentUserMail & ","
End If
If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
scc = scc & "," & aCurrentUserMail & ","
End If

rs.MoveNext





vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 Sub
 

bastanu

AWF VIP
Local time
Today, 09:19
Joined
Apr 13, 2010
Messages
1,174
Hi,
Please replace both procedure with the following ones (exactly the way they are :)):

Code:
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
End If

Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'Obtain the email address for the current user email - "From" email
vRecipientListFrom=Nz(DLookup("CurrentUserMail", "[GMailSettingsQry]"))'Vlad:this line replaces the entire commented out block below
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<NOT NEEDED - REMOVE>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry; ")
'If rss.RecordCount > 0 Then
'rss.MoveFirst
''Do Until rss.EOF 'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
'If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
''vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<NOT NEEDED - REMOVE>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>



'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then rs.MoveFirst

Do Until rs.EOF

    '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 & ","
    Else
        scc = scc & "," & aProjectLeaderMail & ","  'Vlad: you had this here but also below: & aCurrentUserMail & ","
    End If
    If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
        scc = scc & "," & aCurrentUserMail & ","
    End If
    'Vlad:add MaterialPlannerMail
    If InStr(scc,aMaterialPlannerMail)=0 Then scc = scc & "," & aMaterialPlannerMail & ","

rs.MoveNext
Loop

vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 'Vlad:you get the From in this sub in vRecipientListFrom variable so use it
SendEMailCDO vRecipientList, scc, vSubject, vMsg, vRecipientListFrom, vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Vlad:cleanup recordset
rs.close
Set rs = Nothing

'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 Sub


Sub SendEMailCDO(aTo, acc, aSubject, aTextBody, aFrom, aPath)

Dim rss As Recordset

'Vlad -commented out the next line as the aFrom is now populated from the calling procedure
'aFrom = vRecipientListFrom

'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachments
'Date: 25/08/2007
'==========================================


'Dim CDOEmailType As String
Dim txtSendUsing As String
Dim txtPort As String
Dim txtServer As String
Dim txtAuthenticate As String
Dim intTimeOut As String
Dim txtSSL As String
Dim txtusername As String
Dim txtPassword As String
Dim VWPass As String

Dim txtFrom As String

scc = acc

Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry;")
VWPass = VWPass & rss!WPass


'CDOEmailType = rss!EmailType
txtSendUsing = rss!SendUsing
txtPort = rss!ServerPort
txtServer = rss!EmailServer
txtAuthenticate = rss!SMTPAuthenticate
intTimeOut = rss!Timeout
txtusername = GetUserName
txtPassword = VWPass
txtSSL = rss!UseSSL

'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword

On Error GoTo err_SendEMailCDO

Const CdoBodyFormatText = 1
Const CdoBodyFormatHTML = 0
Const CdoMailFormatMime = 0
Const CdoMailFormatText = 1

Dim Message As Object
'Create CDO message object
Set Message = CreateObject("cdo.Message")
With Message.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = txtSendUsing
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = txtPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = txtServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = txtAuthenticate
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = txtusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = txtPassword
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = intTimeOut
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = txtSSL

'code for STARTTLS
If txtPort = 587 Then
.Item("http://schemas.microsoft.com/cdo/configuration/sendtls").Value = True
End If
.Update

End With

DoCmd.Hourglass False

With Message
.To = aTo 'Set email adress
'.CC = aCurrentUserMail
.Subject = aSubject 'Set subject
.TextBody = aTextBody 'Set body text
If Len(acc) > 0 Then .CC = acc 'Set copy to
If Len(aFrom) > 0 Then .From = aFrom 'Set sender address if specified.
If Len(aPath) > 0 Then .AddAttachment (aPath) 'Attach this file
.Send 'Send the message

End With

'Vlad:cleanup recordset
rss.close
Set rss = Nothing

'Debug lines
'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword, VWPass
'Debug.Print aTo, aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print aTo
'Debug.Print aCurrentUserMail
'Debug.Print sCC
'Debug.Print vRecipientList
'Debug.Print aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"
DoCmd.SetWarnings False
'DoCmd.RunMacro "New DAW Email List"
'DoCmd.OpenQuery "Update Material Data File - SAP number with Material No"
DoCmd.Close acForm, "New DAW Sheet - Create Listing"
DoCmd.Close acForm, "Menu"
DoCmd.OpenForm "Menu"
DoCmd.SetWarnings True

'Clean up
Set Message = Nothing

Exit_SendEMailCDO:

Exit Sub

err_SendEMailCDO:
'MsgBox "Error # " & Str(Err.Number) & Chr(13) & Err.Description

strMsg = "Sorry - I was unable to send the email message(s). " & vbNewLine & vbNewLine & _
"Error # " & Str(Err.Number) & Chr(13) & Err.Description
DoCmd.Hourglass False

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub

Cheers,
 

Gismo

Registered User.
Local time
Today, 19:19
Joined
Jun 12, 2017
Messages
1,086
Hi,
Please replace both procedure with the following ones (exactly the way they are :)):

Code:
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
End If

Dim rs As Recordset
Dim rss As Recordset
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String

'Obtain the email address for the current user email - "From" email
vRecipientListFrom=Nz(DLookup("CurrentUserMail", "[GMailSettingsQry]"))'Vlad:this line replaces the entire commented out block below
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<NOT NEEDED - REMOVE>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry; ")
'If rss.RecordCount > 0 Then
'rss.MoveFirst
''Do Until rss.EOF 'Vlad - makes it easier to follow to code -commented out as this has only one record so no need to loop
'If Not IsNull(rss!CurrentUserMail) Then vRecipientListFrom = vRecipientListFrom & rss("CurrentUserMail")
''vRecipientListFrom is not used anywhere, I think it should be in this line:SendEMailCDO vRecipientList, scc, vSubject, vMsg, "", vReportPDF
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<NOT NEEDED - REMOVE>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>



'Obtain all the cc addresses
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then rs.MoveFirst

Do Until rs.EOF

    '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 & ","
    Else
        scc = scc & "," & aProjectLeaderMail & ","  'Vlad: you had this here but also below: & aCurrentUserMail & ","
    End If
    If aCurrentUserMail <> aProductionPlannerMail And aCurrentUserMail <> aProjectLeaderMail Then
        scc = scc & "," & aCurrentUserMail & ","
    End If
    'Vlad:add MaterialPlannerMail
    If InStr(scc,aMaterialPlannerMail)=0 Then scc = scc & "," & aMaterialPlannerMail & ","

rs.MoveNext
Loop

vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[EmailTblQry_NewDaw]") & " " & ", DAW Sheet" & " " & DLookup("[DawNo]", "[EmailTblQry_NewDaw]")
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 'Vlad:you get the From in this sub in vRecipientListFrom variable so use it
SendEMailCDO vRecipientList, scc, vSubject, vMsg, vRecipientListFrom, vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Vlad:cleanup recordset
rs.close
Set rs = Nothing

'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 Sub


Sub SendEMailCDO(aTo, acc, aSubject, aTextBody, aFrom, aPath)

Dim rss As Recordset

'Vlad -commented out the next line as the aFrom is now populated from the calling procedure
'aFrom = vRecipientListFrom

'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachments
'Date: 25/08/2007
'==========================================


'Dim CDOEmailType As String
Dim txtSendUsing As String
Dim txtPort As String
Dim txtServer As String
Dim txtAuthenticate As String
Dim intTimeOut As String
Dim txtSSL As String
Dim txtusername As String
Dim txtPassword As String
Dim VWPass As String

Dim txtFrom As String

scc = acc

Set rss = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry;")
VWPass = VWPass & rss!WPass


'CDOEmailType = rss!EmailType
txtSendUsing = rss!SendUsing
txtPort = rss!ServerPort
txtServer = rss!EmailServer
txtAuthenticate = rss!SMTPAuthenticate
intTimeOut = rss!Timeout
txtusername = GetUserName
txtPassword = VWPass
txtSSL = rss!UseSSL

'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword

On Error GoTo err_SendEMailCDO

Const CdoBodyFormatText = 1
Const CdoBodyFormatHTML = 0
Const CdoMailFormatMime = 0
Const CdoMailFormatText = 1

Dim Message As Object
'Create CDO message object
Set Message = CreateObject("cdo.Message")
With Message.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = txtSendUsing
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = txtPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = txtServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = txtAuthenticate
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = txtusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = txtPassword
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = intTimeOut
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = txtSSL

'code for STARTTLS
If txtPort = 587 Then
.Item("http://schemas.microsoft.com/cdo/configuration/sendtls").Value = True
End If
.Update

End With

DoCmd.Hourglass False

With Message
.To = aTo 'Set email adress
'.CC = aCurrentUserMail
.Subject = aSubject 'Set subject
.TextBody = aTextBody 'Set body text
If Len(acc) > 0 Then .CC = acc 'Set copy to
If Len(aFrom) > 0 Then .From = aFrom 'Set sender address if specified.
If Len(aPath) > 0 Then .AddAttachment (aPath) 'Attach this file
.Send 'Send the message

End With

'Vlad:cleanup recordset
rss.close
Set rss = Nothing

'Debug lines
'Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword, VWPass
'Debug.Print aTo, aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print aTo
'Debug.Print aCurrentUserMail
'Debug.Print sCC
'Debug.Print vRecipientList
'Debug.Print aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"
DoCmd.SetWarnings False
'DoCmd.RunMacro "New DAW Email List"
'DoCmd.OpenQuery "Update Material Data File - SAP number with Material No"
DoCmd.Close acForm, "New DAW Sheet - Create Listing"
DoCmd.Close acForm, "Menu"
DoCmd.OpenForm "Menu"
DoCmd.SetWarnings True

'Clean up
Set Message = Nothing

Exit_SendEMailCDO:

Exit Sub

err_SendEMailCDO:
'MsgBox "Error # " & Str(Err.Number) & Chr(13) & Err.Description

strMsg = "Sorry - I was unable to send the email message(s). " & vbNewLine & vbNewLine & _
"Error # " & Str(Err.Number) & Chr(13) & Err.Description
DoCmd.Hourglass False

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub

Cheers,
Thank you so much
Seems to work well

I will test the different senarios
 

Users who are viewing this thread

Top Bottom