Outlook to Gsuite

bastanu said:
It depends of your definition of blank. Do you have an existing record in that table with the field WPassEnt being Null? If yes you can use a Dlookup to check:
If NZ(Dlookup("[WPassEnt]","WPass")="" Then 'assumes the table will only have one record, the one for the current user
'do your Update

Now if you mean the table is blank like in no records yet you code would fail as you cannot update something that is not there yet. You need to use an append instead (INSERT INTO).
For that to check you use dCOunt:
If DCount("*","WPass")=0 Then 'no record exists
'insert new record in table
Cheers,
Click to expand...
the table is blank, no records, the user needs to enter his password to have 1 record in the table
 
Last edited:
Then use the dCount check along with an Insert Into statement:
Code: 
Dim sSQl as String
sSQL="INSERT INTO WPass [WPassEnt)] VALUES ('" & WPassStr & "');"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True

'or probably better choice
'CurrentDb.Execute sSQL,dbFailonError
 
bastanu said:
Then use the dCount check along with an Insert Into statement:
Code: 
Dim sSQl as String
sSQL="INSERT INTO WPass [WPassEnt)] VALUES ('" & WPassStr & "');"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True

'or probably better choice
'CurrentDb.Execute sSQL,dbFailonError
Click to expand...

The Input Value does not pop up to enter password

If Nz(DLookup("[WPass]", "[EmailTbl]") = "") Then
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title)
End If
Click to expand...

and,
The InputBox value does not update to the Table

Dim sSQl as String
sSQL="INSERT INTO WPass [WPassEnt)] VALUES ('" & WPassStr & "');"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
Click to expand...
error in below and insert into statement
DoCmd.RunSQL sSQL
Click to expand...
 
Last edited:
Gismo,
You have been here long enough to know how to debug.print and post the result.🤔
You appear to have an errant closing bracket???
 
If I had my InputBox in a different sub do i need to define it again in a different sub if i want to call the value entered in the inputbox?
It does not seem to pick it up
even if I call the value updated in to the table it does not see the value

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

Dim txtPassword As String
Dim WPass As String
Dim VWPass As String
Dim WPassStr As String


Set rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDualCurrentUserMail ")
VWPass = vRecipientListUser & rs!WPass & ","


cboEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = WPassStr
intTimeOut = Timeout
txtSSL = 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
Click to expand...
 
Yes, best to make it a global variable or TempVar

Not sure your Tempvar setting is going to work. I am about to test myself.

However walking through the code with F8 would soon tell you. :(

Edit: Yes, Tempvar setting is actually just gobbledeegook. :-(
 
Last edited:
Gasman said:
Yes, best to make it a global variable or TempVar

Not sure your Tempvar setting is going to work. I am about to test myself.

However walking through the code with F8 would soon tell you. :(

Edit: Yes, Tempvar setting is actually just gobbledeegook. :-(
Click to expand...
I tried TempVar also redefining it in the new Sub but still it does not parse in the other Sub

Dim WPassStr As String


Set rs = CurrentDb.OpenRecordset("SELECT * FROM TechPubDualCurrentUserMail ")
VWPass = vRecipientListUser & rs!WPass & ","
Debug.Print

cboEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = WPassStr
Click to expand...
 
Just what are you trying to debug.Print ? :(
You define a TempVar once then change it as needed? It is like a Royal Global variable.
If you are not comfortable with them (I'm going by your attempt to set one), then just use a Global variable, that is set like all other variables.?

You seem to be just cobbling code together, without any thought as to what you want?
What is vRecipientListUser & rs!WPass going to do ?

Step back, take a breath, and think things through. Do it step by step.

First get your Wpass. By that I mean look at the variable either in debug or debug.print to make sure it is set and is a correct value.
Test if you can see it in another sub (a debug.print would be enough)
Then use it in the real sub.

Small steps will get you further, rather than giant leaps all over the place. :)
 
Gasman said:
Just what are you trying to debug.Print ? :(
You define a TempVar once then change it as needed? It is like a Royal Global variable.
If you are not comfortable with them (I'm going by your attempt to set one), then just use a Global variable, that is set like all other variables.?

You seem to be just cobbling code together, without any thought as to what you want?
What is vRecipientListUser & rs!WPass going to do ?

Step back, take a breath, and think things through. Do it step by step.

First get your Wpass. By that I mean look at the variable either in debug or debug.print to make sure it is set and is a correct value.
Test if you can see it in another sub (a debug.print would be enough)
Then use it in the real sub.

Small steps will get you further, rather than giant leaps all over the place. :)
Click to expand...
I feel like I am all over the place yes, I was told to start writing my own VBA so I am attempting to do so.

What is vRecipientListUser & rs!WPass going to do ?
it should look at the query TechPubDualCurrentUserMail and select the password "WPass"


The password has been entered by inputbox and saved into the table
verified, in table
The password is saved as a password format
could this be the reason why I am getting an error when sending the actual mail?
does it recognize the Password format as a password with the ***** mask?

if I hardcode my password, everything seems to be working fine
 
So if you debug.print wpass after getting it from the table, what do you see?
I would not think you would need a recordset, a simple dlookup would be enough.? It is one record per user after all , is it not?
 
@Gizmo,
Can you please post the entire code as you have it now? You seem to have changed tables, now you have Emailtbl (just a note - using a prefix when naming your objects is better and a suffix).
Code: 
If DCount("*","WPass")=0 Then 'no record exists
    Dim sSQl as String, Message, Title, Default
    Message = "Enter Windows Password"
    Title = "Enter Parameters"
    WPassStr = InputBox(Message, Title)
    sSQL="INSERT INTO WPass [WPassEnt] VALUES ('" & WPassStr & "');"
    CurrentDb.Execute sSQL,dbFailonError
End If

'Now you should have the Windows password stored in table WPass in field WPassEnt
'to retrive it in any other place needed use a dlookup
Dim txtPassword
txtPassword=dLookup("[WPassEnt]","[WPass]")

Cheers,
 
bastanu said:
@Gizmo,
Can you please post the entire code as you have it now? You seem to have changed tables, now you have Emailtbl (just a note - using a prefix when naming your objects is better and a suffix).
Code: 
If DCount("*","WPass")=0 Then 'no record exists
    Dim sSQl as String, Message, Title, Default
    Message = "Enter Windows Password"
    Title = "Enter Parameters"
    WPassStr = InputBox(Message, Title)
    sSQL="INSERT INTO WPass [WPassEnt] VALUES ('" & WPassStr & "');"
    CurrentDb.Execute sSQL,dbFailonError
End If

'Now you should have the Windows password stored in table WPass in field WPassEnt
'to retrive it in any other place needed use a dlookup
Dim txtPassword
txtPassword=dLookup("[WPassEnt]","[WPass]")

Cheers,
Click to expand...
Hi,

yes I changed tables, but everything seems to be working well
Will be testing today.

All I want to change is to have all the gmail setting to be read from a query and not from the main form

Thank you everyone for your assistance

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

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


'sSQL = "INSERT INTO EmailTbl [WPass)] VALUES ('" & WPassStr & "');"
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE EmailTbl SET WPass =""" & WPassStr & """"
'DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
End If


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

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

Loop Until rs.EOF

vMsg = "Please find attached new document loaded"
vSubject = "New Document Loaded"
vReportPDF = CurrentProject.Path & "\" & "Email_SB_Notification_From_TechPubs_All_SB_TBL.pdf"

'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
DoCmd.OutputTo acReport, "Email SB Notification - From TechPubs - All - SB TBL", acFormatPDF, vReportPDF
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

'DoCmd.SendObject acSendReport, "Email SB Notification - From TechPubs - All - SB TBL", acFormatPDF, vRecipientList, , , vSubject, vMsg, False
'<<<<<<<<<<<<<<<<<<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!")

Else
MsgBox "No contacts."
End If
DoCmd.RunMacro "Save Loadlist"
End Sub

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

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

Dim rs As Recordset
Dim vRecipientListUser As String

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

Loop Until rs.EOF

aCC = vRecipientListUser
aFrom = vRecipientListUser

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




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


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


cboEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = VWPass
intTimeOut = Timeout
txtSSL = 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 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, txtAuthenticate, intTimeout
'Debug.Print txtServer, txtUserName, txtPassword
'Debug.Print aTo, aCC, 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"

'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 If
End Sub
Click to expand...
 
You are NOT dimming your variables correctly?, only strMsg is a String in that declaration?
Any valid reason why you do the update of the Wpass twice with the same value.? I would have thought, each user would have their own password?
Not really understanding why the first password in the table is the one wanted?, you could have got that when you were getting the emails.?
What is Wpass actually for?, it does not appear to get used anywhere.?

Hard to work out an no indentation. :(

I hope it is working as you want it to, but I am sceptical :unsure: As always though, happy to be proven wrong. :)
 
Gasman said:
You are NOT dimming your variables correctly?, only strMsg is a String in that declaration?
Any valid reason why you do the update of the Wpass twice with the same value.? I would have thought, each user would have their own password?
Not really understanding why the first password in the table is the one wanted?, you could have got that when you were getting the emails.?
What is Wpass actually for?, it does not appear to get used anywhere.?

Hard to work out an no indentation. :(

I hope it is working as you want it to, but I am sceptical :unsure: As always though, happy to be proven wrong. :)
Click to expand...
Hi,

It is working, funny enough
I removed the additional WPass update and I did my indentation this morning
WPass is the windows sign on password which I write to a file and deleted once done with the application
this is all trial and error to me and appreciate all the assistance

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

I copied the code to another DB where I need to email from different sections.

for some reason, VBA is not reading any values from my Gmail setting qry
CDOEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = VWPass
intTimeOut = Timeout
txtSSL = UseSSL

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


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

Set rs = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry ")

CDOEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = VWPass
intTimeOut = Timeout
txtSSL = 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
Click to expand...
 
You do not use the recordset you just set:
CDOEmailType = rs("EmailType")
....
 
Also
Code: 
Set rs = CurrentDb.OpenRecordset("SELECT * FROM EmailTBL ")
VWPass = VWPass & rs!WPass
could be:
VWPass=dLookup("[WPass]","[EmailTBL]")
 
bastanu said:
You do not use the recordset you just set:
CDOEmailType = rs("EmailType")
....
Click to expand...
Hi,

Sorry not sure what you mean my do not use the recordset i just set

All the gmail setting should be read from the GmailSettingQry

adding rs to emailtype did not make a difference

Set rs = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry ")

CDOEmailType = rs("EmailType")
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = VWPass
intTimeOut = Timeout
txtSSL = UseSSL
Click to expand...
 
They all should have the rs("FieldName") or rs!FieldName. Look at the first one for the WPass.
Would you please post the entire code as you have it right now (all the procedures and functions you added to support this emailing task)? Posting small segment is confusing and doesn't help much!

Cheers,
Vlad
 
bastanu said:
They all should have the rs("FieldName") or rs!FieldName. Look at the first one for the WPass.
Would you please post the entire code as you have it right now (all the procedures and functions you added to support this emailing task)? Posting small segment is confusing and doesn't help much!

Cheers,
Vlad
Click to expand...
Hi,

Below is the code

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

Private Sub Excecute_Click()


Dim SQL As String
Dim WPassStr As String
Dim sSQL 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)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE EmailTbl SET WPass =""" & WPassStr & """"
DoCmd.SetWarnings True
End If


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

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

Loop Until rs.EOF

vMsg = [Message]
vSubject = "New DAW Sheet Listing - Registration: " & " " & [Registration]
vReportPDF = CurrentProject.Path & "\" & "DAW Sheet"

'<<<<<<<<<<<<<<<<<<<<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!")

Else
MsgBox "No contacts."
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
Dim vToUser As String
Dim vProductionPlannerMail As String

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

Loop Until rs.EOF

aCC = vProductionPlannerMail
aFrom = vToUser

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


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



Set rs = CurrentDb.OpenRecordset("SELECT * FROM GMailSettingsQry ")

'CDOEmailType = rs!EmailType
txtSendUsing = rs!SendUsing
txtPort = rs!ServerPort
txtServer = rs!EmailServer
txtAuthenticate = rs!SMTPAuthenticate
intTimeOut = rs!Timeout
txtusername = GetUserName
txtPassword = rs!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 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, txtAuthenticate, intTimeout
'Debug.Print txtServer, txtUserName, txtPassword
'Debug.Print aTo, aCC, 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"

'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 If
End Sub
Click to expand...
 
You must log in or register to reply here.

Similar threads

oxicottin
Solved Out Of Memory error when emailing
Replies
8
Views
254
oxicottin
oxicottin
A
Match two numbers and then update
Replies
10
Views
209
Gasman
Gasman
B
Outlook - Filtered Unread, Server duplicate emails & think Unread = False not work so errors
Replies
6
Views
283
bignose2
B
D
Default Signature new outlook current user
Replies
17
Views
366
GPGeorge
GPGeorge
A
Send Report Through Access Form
Replies
10
Views
281
Gasman
Gasman

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom