Outlook to Gsuite (1 Viewer)

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
Glad to hear you are making progress learning to debug your code, it is an essential skil that will greatly help you along your programming way...

I would suggest you use DAO.Recordset in your declarations to avoid ambiguity (there is another beast called ADO.Recordset and you don't want Access to get confused which one you want).

Can you please attach a copy of the EmailTBL table (or at least a screen shot)? As I explained a few times, it is not advisible to keep information that is not meant to be duplicated, such as WPassStr (the manually entered Windows password of the current user), the body of the email message and the "Registration" component of the email subject in a table that is meant as a storage for multiple recipient email addresses. You should really move those three fields to the GMailSettings table.

I noticed you also lost along the way the vMsg variable, it is not set anywhere but you do pass it to Colin's CDO function. Try to go over the code I uploaded earlier (use the text attachment as it is indented much better than the one posted with the code tags).

Cheers,
Hi,

Yes, I am slowly getting there, I just dont know why I am feeling so using VBB
Yesterday afternoon I wanted to add a recipient from another control to the CC.
I did not want to add it incase it messes up my code :)

But I did it never the less and it worked just fine, suppose it wasnt that a big of a change
I will be moving the password to the gmail settings tbl this morning

I still want to make the additional change where the password being entered is masked with an * but I suppose that is a project at a later stage

1614920828705.png

I have one issue with the ProjectLeaderMail i added, what if it is blank or N/ A to this mail? it will give me an error
Below is the EmailTbl
1614920808511.png


I need to thank everyone for the assistance, much appreciated, I was very chuffed when the email was delivered successfully.
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 18:58
Joined
Sep 21, 2011
Messages
14,046
Hi,

Yes, I am slowly getting there, I just dont know why I am feeling so using VBB
Yesterday afternoon I wanted to add a recipient from another control to the CC.


I have one issue with the ProjectLeaderMail i added, what if it is blank or N/ A to this mail? it will give me an error
So test for it? Something along the lines of

Code:
If NOT ISNULL(aProjectLeaderEmail) AND aProjectLeaderEmail <> "N/A" then
    aCC = aCC & "," & aProjectLeaderEmail
End If

However as you are using the delimiter at the front, you would need to check that the first character is not a comma, if you did not have any existing aCC content.?
I have always placed it at the end as I build the email list, as Outlook does not complain if you end with a delimiter. Not sure if Gmail is the same?, but you get the picture. You can code to your particular requirements.

I'll let you decide where to place that code.? :)
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
So test for it? Something along the lines of

Code:
If NOT ISNULL(aProjectLeaderEmail) AND aProjectLeaderEmail <> "N/A" then
    aCC = aCC & "," & aProjectLeaderEmail
End If

However as you are using the delimiter at the front, you would need to check that the first character is not a comma, if you did not have any existing aCC content.?
I have always placed it at the end as I build the email list, as Outlook does not complain if you end with a delimiter. Not sure if Gmail is the same?, but you get the picture. You can code to your particular requirements.

I'll let you decide where to place that code.? :)
Thank you, works perfect
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:58
Joined
Sep 21, 2011
Messages
14,046
That code does not allow for Zero Length String (ZLS) so if that could be an issue, also test for that.
Only you know your data.
 

bastanu

AWF VIP
Local time
Today, 11:58
Joined
Apr 13, 2010
Messages
1,401
I would suggest you move the CC code from SendEMailCDO to the Excecute_Click() where you already loop through the EmailTBL then pass it to SendEMailCDO as the aCC argument.

As for the password mask just add an input mask "Password" to the WPass field in the table. If you want to also mask it while it is being entered it gets a bit more complicated as you would need a custom inputbox function.
Cheers,
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
Hi,

I still seem to have an issue when there is no value in ProjectLeaderMail

aProjectLeaderMail = ProjectLeaderMail

If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
If Len(aCC) > 0 Then .CC = aCC & "," & aProjectLeaderMail 'Set copy to
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:58
Joined
Sep 21, 2011
Messages
14,046
You need to show more than that? :(
What happens if there is no value in aCC ?

What actually is the issue? :(
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
You need to show more than that? :(
What happens if there is no value in aCC ?

What actually is the issue? :(
There will always be a value in aCC

I have to copy either the anager or the quality inspector, depending on the type of transaction

but on some aircraft, there is a project then the project leader must be copied in on the mail

in the case today, there was no project loaded on this aircraft so the projectleadermail will be a n/a


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

Dim vProductionPlannerMail As String
Dim aProjectLeaderMail As String
Dim rs As Recordset

aFrom = CurrentUserMail
aCC = CurrentUserMail
aProjectLeaderMail = ProjectLeaderMail

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

'Debug lines
Debug.Print txtSendUsing, txtPort, txtServer, txtAuthenticate, intTimeOut, txtSSL
'Debug.Print txtusername, txtPassword, VWPass
'Debug.Print aTo, aCC, aFrom
'Debug.Print aSubject
'Debug.Print aTextBody
'Debug.Print aPath



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

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


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 True

With Message
.To = aTo 'Set email adress
.Subject = aSubject 'Set subject
.TextBody = aTextBody 'Set body text
If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
If Len(aCC) > 0 Then .CC = aCC & "," & aProjectLeaderMail '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 If
End With

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"

'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

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 18:58
Joined
Sep 21, 2011
Messages
14,046
There will always be a value in aCC
But for contingency, I think i need to code the aCC in case it is blank

So which will be True? :(
As I said, only YOU lnow your data. yes, it would be wise to allow for a missing aCC, but if you code never to allow a missing aCC, it is somewhat redundant?

have you tried emailaddress then the delimiter? as I mentioned previously?, then you can just concatenate email addresses and not worry if it is empty or not.?
Test Gmail to see if it minds a , at the end of the email string. Easy enough to remove anyway in one foul swoop. :)
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
So which will be True? :(
As I said, only YOU lnow your data. yes, it would be wise to allow for a missing aCC, but if you code never to allow a missing aCC, it is somewhat redundant?

have you tried emailaddress then the delimiter? as I mentioned previously?, then you can just concatenate email addresses and not worry if it is empty or not.?
Test Gmail to see if it minds a , at the end of the email string. Easy enough to remove anyway in one foul swoop. :)
does the code not check for null?

If Len(aCC) > 0 Then .CC = aCC

Which is True? : always have a to and cc and sometime the cc has the projectleader mail

Because my mail have many variables, i write the addresses in to a table as per below, so I dont think email addresses with delimeter will work, i might be incorrect on this.

Below is my mail table

1615210685381.png
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 18:58
Joined
Sep 21, 2011
Messages
14,046
I am still not understanding what the issue is?
does the code not check for null?
No, that just checks for a zero length string I believe.

Code:
so I dont think email addresses with delimeter will work, i might be incorrect on this.
You are using email addresses with delimiters now ?
 
Last edited:

bastanu

AWF VIP
Local time
Today, 11:58
Joined
Apr 13, 2010
Messages
1,401
I would suggest you move the CC code from SendEMailCDO to the Excecute_Click() where you already loop through the EmailTBL then pass it to SendEMailCDO as the aCC argument.
I see you still haven't done what I suggested, how do you expect aProjectLeaderMail = ProjectLeaderMail to have a value if you don't get it from anywhere? You need to add it inside the recordset loop in the previous sub then properly pass it as the second argument (aCC) of the SendEmailCDO sub.

Cheers,
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
I see you still haven't done what I suggested, how do you expect aProjectLeaderMail = ProjectLeaderMail to have a value if you don't get it from anywhere? You need to add it inside the recordset loop in the previous sub then properly pass it as the second argument (aCC) of the SendEmailCDO sub.

Cheers,
Hi,

ProjectLeaderMail comes from my emailTbl
it works fine if the aircraft is a project and there is a project leader attached to this aircraft

I have looked at moving the projectmail to the record set, I am just afraid i screw it up again and it doesnt word, but I will attempt it once I have the time during the week to test it out.

1615264645283.png
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
I am still not understanding what the issue is?

No, that just checks for a zero length string I believe.

Code:
so I dont think email addresses with delimeter will work, i might be incorrect on this.
You are using email addresses with delimiters now ?
Al my mails sent from this DB will have a to and always a CC, depending on the aircraft setup, the cc will either be to a CAMO manager or to quality.
then, depending on the project, if this is a new aircraft, it will be a project then there will be an additional email to the cc field, if not a project, then only one cc recipient.

in the case of yesterday, the aircraft was not a project and the aProjectLeaderMail was blank and that had the error
 
Last edited:

bastanu

AWF VIP
Local time
Today, 11:58
Joined
Apr 13, 2010
Messages
1,401
The way you show it to us makes no sense, you assign a variable to a value (aProjectLeaderMail = ProjectLeaderMail) , but that is not declared\defined anywhere to be seen. We know it is a field in your table but simply referencing that will not magically work; move it to the first sub in the recordset loop similar to the To email:
Code:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBL ")
 rs.MoveFirst
Do until rs.EOF
    If Not IsNull(rs!email) Then vRecipientList = vRecipientList & rs!To & "," 
    vProjectLeader = vProjectLeader & rs!ProjectLeaderMail & "," 
    rs.MoveNext
Loop
Cheers,
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
The way you show it to us makes no sense, you assign a variable to a value (aProjectLeaderMail = ProjectLeaderMail) , but that is not declared\defined anywhere to be seen. We know it is a field in your table but simply referencing that will not magically work; move it to the first sub in the recordset loop similar to the To email:
Code:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBL ")
rs.MoveFirst
Do until rs.EOF
    If Not IsNull(rs!email) Then vRecipientList = vRecipientList & rs!To & ","
    vProjectLeader = vProjectLeader & rs!ProjectLeaderMail & ","
    rs.MoveNext
Loop
Cheers,
Hi,

Currently in the process of moving it as we speak

It was declaired in Execute as was advised

will report back later :)
 
Last edited:

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
Hi,

Currently in the process of moving it as we speak

It was declaired in Execute as was advised

will report back later :)
I have made the alterations as best as I could

I am still having issue having an output on aCC
I have declared it as a Global value

aCC works fine in Execute but when I send mail, there is on value in Debug.Print aCC in SendMailCDO

Option Explicit
Dim strFilename As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aCurrentUserMail As String
Dim Acc As String



Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String


'Enter Password
If Nz(DLookup("[WPass]", "[GMailSettingsQry]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE GMailSettingsQry SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If


Dim rs As Recordset
Dim vRecipientList As String
Dim vRecipientListCC As String
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String


aProjectLeaderMail = ProjectLeaderMail
aProductionPlannerMail = ProductionPlannerMail

'Set To Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!To) Then
vRecipientList = vRecipientList & rs("To") & "," 'Vlad - changed email separator to comma
rs.MoveNext
Else
rs.MoveNext
End If

Loop Until rs.EOF



'Set CC Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
Acc = Acc & "," & aProjectLeaderMail & "," & aProductionPlannerMail & ";" & aCurrentUserMail

rs.MoveNext
Else
rs.MoveNext
End If

Loop Until rs.EOF


'vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration")
vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[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, "", vSubject, vMsg, "", vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'MsgBox ("Report successfully eMailed!")

'Debug.Print aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print Acc

Else
MsgBox "No contacts."
End If
End If
'DoCmd.RunMacro "New DAW Email List"
End Sub

Public Function GetUserName() As String
GetUserName = Environ("UserName")
End Function

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


Dim rs As Recordset

aFrom = CurrentUserMail
aCurrentUserMail = CurrentUserMail


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

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



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

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


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 True

With Message
'.To = aTo 'Set email adress
.To = 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.Print Acc
'Debug.Print aTo, Acc, aFrom
'Debug.Print Acc & aProjectLeaderMail & aCurrentUserMail & aProductionPlannerMail

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"

'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

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub
 

bastanu

AWF VIP
Local time
Today, 11:58
Joined
Apr 13, 2010
Messages
1,401
Here you go, please review the comments:
Code:
Option Explicit
Dim strFilename As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aCurrentUserMail As String
'Dim Acc As String



Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String


'Enter Password
If Nz(DLookup("[WPass]", "[GMailSettingsQry]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE GMailSettingsQry SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If


Dim rs As Recordset
Dim vRecipientList As String
Dim vRecipientListCC As String
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String


'aProjectLeaderMail = ProjectLeaderMail 'these line do nothing good
'aProductionPlannerMail = ProductionPlannerMail '

'Set To Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
  If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
  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 ProductionPlannerMail = aProductionPlannerMail & rs("ProductionPlannerMail") & "
  If Not IsNull(rs!CurrentUserMail ) Then aCurrentUserMail = aCurrentUserMail & rs("CurrentUserMail ") & "," 'aFrom
rs.MoveNext
End If

Loop Until rs.EOF



'Set CC Recipient
'Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
'If rs.RecordCount > 0 Then
'rs.MoveFirst
'Do
'If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
'Acc = Acc & "," & aProjectLeaderMail & "," & aProductionPlannerMail & ";" & aCurrentUserMail

'rs.MoveNext
'Else
'rs.MoveNext
'End If

'Loop Until rs.EOF


vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration") 'you already have the recordset open this is faster
'vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[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, aProjectLeaderMail , vSubject, vMsg, aCurrentUserMail , vReportPDF  'notice the vMsg is empty looks like you removed from the table
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'MsgBox ("Report successfully eMailed!")

'Debug.Print aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print Acc

Else
MsgBox "No contacts."
End If
End If
'DoCmd.RunMacro "New DAW Email List"
End Sub

Public Function GetUserName() As String
GetUserName = Environ("UserName")
End Function

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


Dim rs As Recordset

'aFrom = CurrentUserMail 'again you cannot do this, you need to use a recordset or dlookups
'aCurrentUserMail = CurrentUserMail'see above


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

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



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

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


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 True

With Message
.To = aTo 'Set email adress why do you loop through the table if you don;t use the vRecipients????
'.To = 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.Print Acc
'Debug.Print aTo, Acc, aFrom
'Debug.Print Acc & aProjectLeaderMail & aCurrentUserMail & aProductionPlannerMail

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"

'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

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub

Cheers,
Vlad
 

Gismo

Registered User.
Local time
Today, 20:58
Joined
Jun 12, 2017
Messages
1,298
Th
Here you go, please review the comments:
Code:
Option Explicit
Dim strFilename As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aCurrentUserMail As String
'Dim Acc As String



Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String


'Enter Password
If Nz(DLookup("[WPass]", "[GMailSettingsQry]")) = "" Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE GMailSettingsQry SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If


Dim rs As Recordset
Dim vRecipientList As String
Dim vRecipientListCC As String
Dim vMsg As String
Dim vSubject As String
Dim vReportPDF As String


'aProjectLeaderMail = ProjectLeaderMail 'these line do nothing good
'aProductionPlannerMail = ProductionPlannerMail '

'Set To Recipient
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
  If Not IsNull(rs!To) Then vRecipientList = vRecipientList & rs("To") & ","
  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 ProductionPlannerMail = aProductionPlannerMail & rs("ProductionPlannerMail") & "
  If Not IsNull(rs!CurrentUserMail ) Then aCurrentUserMail = aCurrentUserMail & rs("CurrentUserMail ") & "," 'aFrom
rs.MoveNext
End If

Loop Until rs.EOF



'Set CC Recipient
'Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBLQry_NewDaw; ")
'If rs.RecordCount > 0 Then
'rs.MoveFirst
'Do
'If Not IsNull(aProjectLeaderMail) And aProjectLeaderMail <> "N/A" Then
'Acc = Acc & "," & aProjectLeaderMail & "," & aProductionPlannerMail & ";" & aCurrentUserMail

'rs.MoveNext
'Else
'rs.MoveNext
'End If

'Loop Until rs.EOF


vSubject = "New DAW Sheet Listing - Registration: " & " " & rs("Registration") 'you already have the recordset open this is faster
'vSubject = "New DAW Sheet Listing - Registration: " & " " & DLookup("[Registration]", "[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, aProjectLeaderMail , vSubject, vMsg, aCurrentUserMail , vReportPDF  'notice the vMsg is empty looks like you removed from the table
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'MsgBox ("Report successfully eMailed!")

'Debug.Print aProjectLeaderMail, aProductionPlannerMail, aCurrentUserMail
'Debug.Print Acc

Else
MsgBox "No contacts."
End If
End If
'DoCmd.RunMacro "New DAW Email List"
End Sub

Public Function GetUserName() As String
GetUserName = Environ("UserName")
End Function

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


Dim rs As Recordset

'aFrom = CurrentUserMail 'again you cannot do this, you need to use a recordset or dlookups
'aCurrentUserMail = CurrentUserMail'see above


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

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



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

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


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 True

With Message
.To = aTo 'Set email adress why do you loop through the table if you don;t use the vRecipients????
'.To = 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.Print Acc
'Debug.Print aTo, Acc, aFrom
'Debug.Print Acc & aProjectLeaderMail & aCurrentUserMail & aProductionPlannerMail

DoCmd.Hourglass False

'Show message
MsgBox "The email message has been sent successfully. ", vbInformation, "EMail message"

'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

MsgBox strMsg, vbCritical, "EMail message"

strMsg = ""

Resume Exit_SendEMailCDO

End Sub

Cheers,
Vlad

Hi,

Thank you, I looked at the code and the comments, makes a bit more sense now

I'm just not sure where you are assigning the values for aCC ? Acc is not defined
CC must be 1. ProjectLeaderMail if there is a value in EmailTBLQry_NewDaw
2. ProductionPlannerMail
3. CurrentUserMail if value is not = to ProductionPlannerMail (Only decided to include the If this morning, not yet coded)

All my other Debug.Print seems to work fine but there is no CC recipients in the mail


1615354448264.png




The below I just used to test, not to overload my managers mail, Instead just use myself as the To value

1615354372226.png



I ended up with below code, seems to be ok
Had to remove 'If Len(Acc) > 0 Then .CC = acc

1615382947926.png
 
Last edited:

bastanu

AWF VIP
Local time
Today, 11:58
Joined
Apr 13, 2010
Messages
1,401
That should be:
aProductionPlannerMail = aProductionPlannerMail & rs("ProductionPlannerMail") & ""
 

Users who are viewing this thread

Top Bottom