Outlook to Gsuite

[Gismo]

Try this:

Option Explicit
Dim strFilename As String, strMsg As String

Private Sub Excecute_Click()
Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail As String
Dim aCurrentUserMail As String
DIm sCC 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 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") & ","

  '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!CurrentUserMail ) AND rs!CurrentUserMail <> "N/A" Then aCurrentUserMail = aCurrentUserMail & rs("CurrentUserMail ") & ","
'It send mail, I need Production Planner, Project leader and Current user mail (If not the same as production planner)  
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
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, sCC, 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

Note that manipulation of the sCC string should be done in the first sub (Excecute_Click) and passed as the aCC( second argument) of the SendEmailCDO sub.

Cheers,

Thank you very much

Looks and works amazingly well

All I will add now is a masked password when the user enters his/her password, not to have the password entered in the inputbox visible

 

[bastanu]

Here is a database that contains a module that gives you a replacement for the built-in input box with a password mask. Simply import the module into your db and replace WPassStr = InputBox(Message, Title) with WPassStr = InputBoxDK(Message, Title)

Cheers,
Vlad

 

[Gismo]

Here is a database that contains a module that gives you a replacement for the built-in input box with a password mask. Simply import the module into your db and replace WPassStr = InputBox(Message, Title) with WPassStr = InputBoxDK(Message, Title)

Cheers,
Vlad

Thank you very much

will test it

 

[Gismo]

Here is a database that contains a module that gives you a replacement for the built-in input box with a password mask. Simply import the module into your db and replace WPassStr = InputBox(Message, Title) with WPassStr = InputBoxDK(Message, Title)

Cheers,
Vlad

Hi,

InputboxDK is not recognized, requires to be defined

 

[bastanu]

Did you import the module from the sample db?

 

[Gismo]

Did you import the module from the sample db?

Hi, Yes I did

 

[bastanu]

Please show me the full code again, it should work if you imported the module. Did you compile the project? What line do you get that error on?

EDIT: what happens in the sample I've sent you if you run Query1? Open the module and compile, do you get an error?

 

[Gismo]

When I run the Query 1 from you DB it works fine

When I run the code in my DB it get a ByRef argument mismatch

 

[Gasman]

When I run the Query 1 from you DB it works fine

When I run the code in my DB it get a ByRef argument mismatch
View attachment 90042

That will likely be as you have NOT defined your variables correctly? none of your Dimmed variables are declared as strings, PLUS you MUST define everyone separately as string.

 

[Gismo]

That will likely be as you have NOT defined your variables correctly? none of your Dimmed variables are declared as strings, PLUS you MUST define everyone separately as string.

I Had it defined but received other errors so I removed it again as the sample DB did not have InputBoxDK defined, but then it ran from a query and not VB

When I define InputBoxDK, i get a Expected array error

 

[Gasman]

You are NOT learning anything here.

Vlad gave you a function in that module

Public Function InputBoxDK(Prompt As String, Optional Title As String, _

so you do not define function names as strings?
I was referring to your code that Dims Message, Title and Default (I would have thought, that would be a reserved name as well?)
I cannot copy the code as you pasted it as a picture and not actual code

Vlad is likely asleep ATM, which is the only reason I am chipping in.

YOU have to define EACH variable as a type suitable for what you are going to use it for and how it is expected to be received.?

In this case Vlad set the function to expect the parameters to InputBoxDK as strings as see by the statement above.
As you have not bothered to say what your variables above are meant to be, they are defined by default as variants.?

So try

Dim Message AS String, Title AS String, Default AS String

I am still not sure about that Default word, so google for Access reserved names and check.

HTH

 

[Gismo]

You are NOT learning anything here.

Vlad gave you a function in that module

Public Function InputBoxDK(Prompt As String, Optional Title As String, _

so you do not define function names as strings?
I was referring to your code that Dims Message, Title and Default (I would have thought, that would be a reserved name as well?)
I cannot copy the code as you pasted it as a picture and not actual code

Vlad is likely asleep ATM, which is the only reason I am chipping in.

YOU have to define EACH variable as a type suitable for what you are going to use it for and how it is expected to be received.?

In this case Vlad set the function to expect the parameters to InputBoxDK as strings as see by the statement above.
As you have not bothered to say what your variables above are meant to be, they are defined by default as variants.?

So try

Dim Message AS String, Title AS String, Default AS String

I am still not sure about that Default word, so google for Access reserved names and check.

HTH

Gasman, I understand what you are saying.

My question is,

WPass = InputBox(Message, Title)

Message and Title is not defined, and the code is as what was advised to used before I changed to masked password, and the code worked fine

now I am adding "DK" to the code, then I get the error on "Message"

that is what is confusing me

In the modInput module I do have the the code as above mentioned

Public Function InputBoxDK(Prompt As String, Optional Title As String, _

I copied the code as Vlad advised and only changed InputBox to InputBoxDK, also as advise.

And in my code, I do have Message, Title and Default defined, see the below and screenshot you are referring to

Option Compare Database
Option Explicit
Dim aTo, aCC, aFrom, aPath, FileList, aTextBody, aSubject, strFilename, strMsg As String

Private Sub emailReportAsPDF_Click()


DoCmd.OpenQuery "Update TechPubDual Mail List"
DoCmd.OpenQuery "Update EmailTBL - Current User"

Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
Dim InputBoxDK As String


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

 

[Gasman]

What have I just said?
The only variable that is actually defined as a string in the Dim aTo statement is strMsg from that statement. So I would say you do NOT understand what I am saying.?
Define them like below, though you can put them on the same line

Dim SQL As String
Dim WPassStr As String
Dim sSQL As String
Dim InputBoxDK As String ' Get rid of this line.!!!!!

I have to go out now, and you will need to wait for someone else to chip in or Vlad to wake up.

 

[bastanu]

@Gizmo,
Gasman gave you the answer twice:
You have:

'Enter Password
If Nz(DLookup("[WPass]", "[EmailTbl]")) = "" Then
Dim Message, Title, Default

The InOutBoxDK function declared in the module expects strings but you provide variants.
So:

'Enter Password
If Nz(DLookup("[WPass]", "[EmailTbl]")) = "" Then
Dim Message AS STRING, Title AS STRING, Default AS STRING

should work but as Gasman pointed out you need to remove the line where you declare the function as string in your sub (as it is already declared in the module you imported from the sample).

 

[Gismo]

@Gizmo,
Gasman gave you the answer twice:
You have:

'Enter Password
If Nz(DLookup("[WPass]", "[EmailTbl]")) = "" Then
Dim Message, Title, Default

The InOutBoxDK function declared in the module expects strings but you provide variants.
So:

'Enter Password
If Nz(DLookup("[WPass]", "[EmailTbl]")) = "" Then
Dim Message AS STRING, Title AS STRING, Default AS STRING

should work but as Gasman pointed out you need to remove the line where you declare the function as string in your sub (as it is already declared in the module you imported from the sample).

Thank you

 

[bastanu]

Did it work, sorry if we sound overreaching?

Cheers,

 

[Gismo]

Did it work, sorry if we sound overreaching?

Cheers,

it did, thank you

my problem is, as i go along, i change my requirement then things go wrong and wont work

I just could not understand why all was well with Dim Message, Title, Default but when I changed to InputboxDK I had to change to Dim Message AS STRING, Title AS STRING, Default AS STRING

I thing thaw as throwing me off a bit

but i just added code and seems to work ok

'Show message
msgboxstring = "An email Notification has been sent successfully to:" & " " & DLookup("[ProductionPlanner]", "[EmailTblQry_QualityToPlanner]")
MsgBox msgboxstring, vbInformation, "EMail message"

 

[Gasman]

I just could not understand why all was well with Dim Message, Title, Default but when I changed to InputboxDK I had to change to Dim Message AS STRING, Title AS STRING, Default AS STRING

For the most part, it I suspect it would not matter much in a lot of circumstances, but it is being very lazy, in my opinion.? Variants can handle Nulls, but I personally have hardly ever used them, but they will be there for a purpose.

ALWAYS define your variables for EACH TYPE! I tend to group strings together, integers, longs etc when I Dim any variable.

Because Vlads function expected strings, that is what you need to supply, no other type.

Also you do not seem to be aware of the difference between a function and a string, just naming stuff adhoc.?
Never have anything named EXACTLY the same. How is Access (or anyone for that matter) meant to know which you are referring to.?

If you are going to start changing code supplied to you, YOU have to understand how it works. This is why I prefer to prod people into thinking for themselves and then hopefully the knowledge will stick. Too many times, I see a solution supplied, and then the person comes back and states 'Now I want to do this' or 'It doesn't work (because they have not even changed the names to suit ). They do not appear to want to think for themselves, and that hurts no one but themselves.

If you want to play at coding, start learning. We are on 120 posts in this thread for a minor problem. Not the initial query, but simple code to support it. There is no easy way around that, believe me I know.

 

[Gismo]

Hi All,

just a quick one to ask for assistance. I know, my questions are never a quick one

When submitting a document to be mailed, the system requires to enter the gmail account password

Now for some reason the users does not enter the password, they either click on ok or cancel or on the X to close.

The macro then runs but no mail is sent.

Ok should not be active when the password has not been entered.
And when canceled, the macro should not run

Please could you advise on where the changes should be made as I am not sure

Also, if the password is not entered or incorrect, the macro should not run.

error of incorrect password should be shown then to re enter password

Option Compare Database
Option Explicit
Dim strFilename As String, strMsg As String
Dim aProjectLeaderMail As String
Dim aProductionPlannerMail 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

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

End If

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

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(rs!To) Then vRecipientListFrom = vRecipientListFrom & rs("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!CurrentUserMail) And rs!CurrentUserMail <> "N/A" Then aCurrentUserMail = aCurrentUserMail & rs("CurrentUserMail") & ","
'It send mail, I need Production Planner, Project leader and Current user mail (If not the same as production planner)
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]")
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
'Debug.Print sCC
'Debug.Print vRecipientList
'Debug.Print aCurrentUserMail

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

 

[bastanu]

Because you are using the built in InputBox (indirectly via the modified InputBoxDK that allows the masking) you cannot easily disable the OK button. To do that you would need to replace it with your own modal form.
To exit the code if the user does not enter a password simply add this line after the call to the inputbox:

WPassStr = InputBoxDK(Message, Title) '(* Password)
If WPassStr ="" Then Msgbox "You did not enter a password, the emailing process will end",vbCritical :Exit Sub

To check if the password is correct you would need to either store it in the database (which would obviously pose certain risks) or wait until you get the Gmail authentication error. What happens now if the wrong password is entered?

Cheers,