Outlook to Gsuite (1 Viewer)

isladogs

MVP / VIP
Local time
Today, 23:43
Joined
Jan 14, 2017
Messages
18,186
OK so you've copied a section of code from my app together with additional code by Vlad.
Trying to combine two different sections of code isn't always simple
However all the functionality you need should be in my example app

There are 3 main ways of including an Access report with an email
The easiest way to attach a report to an email is to save it as a PDF. The example app includes code to attach a saved file. Use that.
It is also possible to save a report as an image file and use that as an attachment but I don't recommend that
The third method would be to include an inline image of the report as part of the email body (HTML email only). However as many email apps now block inline images for security reasons, that isn't usually a good solution either
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
OK so you've copied a section of code from my app together with additional code by Vlad.
Trying to combine two different sections of code isn't always simple
However all the functionality you need should be in my example app

There are 3 main ways of including an Access report with an email
The easiest way to attach a report to an email is to save it as a PDF. The example app includes code to attach a saved file. Use that.
It is also possible to save a report as an image file and use that as an attachment but I don't recommend that
The third method would be to include an inline image of the report as part of the email body (HTML email only). However as many email apps now block inline images for security reasons, that isn't usually a good solution either
Thank you for the info

i would really like to attached the report from access as I did with the code provided

i would rally appreciate it if you could assist as I am really not that good at VBA and would be so grateful if this could be accomplished
 

Gasman

Enthusiastic Amateur
Local time
Today, 23:43
Joined
Sep 21, 2011
Messages
14,048
i would rally appreciate it if you could assist as I am really not that good at VBA and would be so grateful if this could be accomplished
You really need to start learning VBA, if you intend to do work like this?
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
You really need to start learning VBA, if you intend to do work like this?
I agree and I would love to have the knowledge to be able to write VBA as you guys, it really is amazing with the suggestions and sample I receive on this site

every time I ask you guys i learn a lot. and i do search online quite bit and look at youtube videos
 

isladogs

MVP / VIP
Local time
Today, 23:43
Joined
Jan 14, 2017
Messages
18,186
OK I'll give you a brief guide to how you could do it. You'll learn more by creating the code yourself.

1. Save the report as a PDF using code or the export wizard
2. Now create a string variable e.g. strFilePath and set its value to the PDF you just saved
3. Use that value for the attachment part of the CDO Email code and send the email.
If you decide to use my form for sending the email, you can populate the attachment textbox with the variable value

Hope that helps.
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
OK I'll give you a brief guide to how you could do it. You'll learn more by creating the code yourself.

1. Save the report as a PDF using code or the export wizard
2. Now create a string variable e.g. strFilePath and set its value to the PDF you just saved
3. Use that value for the attachment part of the CDO Email code and send the email.
If you decide to use my form for sending the email, you can populate the attachment textbox with the variable value

Hope that helps.
Ok I will give it a go,

I am basically using all of you CDO code, testemail, which is my SendEmail
you testHTMLMail, SendMailCDO , sub sendTHMMail and btnEmail

Then I will add the code which you guys assisted in writing to attach the report and get my recipient list from my query

i dont really want to go the route of saving the PDF as in the next step will be to add a multi page report representing one page page breaks
all that you guys have been assisting me, is now all coming together, and looks really good
so once again, thank you all for all the assistance
 

Gasman

Enthusiastic Amateur
Local time
Today, 23:43
Joined
Sep 21, 2011
Messages
14,048
i dont really want to go the route of saving the PDF as in the next step will be to add a multi page report representing one page page breaks
I don't think you have any option, now that you have to change the method of sending?
Bite the bullet and work with what you have. :)
 

bastanu

AWF VIP
Local time
Today, 16:43
Joined
Apr 13, 2010
Messages
1,401
@ Gizmo - the code I gave you had an error that I now corrected (messed up with copy and paste and pasted Colin's sub inside the previous one so it was missing the End Sub)

I have modified the code so it should work OK once you set up your email server settings.

Code:
Sub emailReportAsPDF()
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

End Sub

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

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

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 Sub
Cheers,
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
@ Gizmo - the code I gave you had an error that I now corrected (messed up with copy and paste and pasted Colin's sub inside the previous one so it was missing the End Sub)

I have modified the code so it should work OK once you set up your email server settings.

Code:
Sub emailReportAsPDF()
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

End Sub

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

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

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 Sub
Cheers,
Hi,

Yes I noticed the End sub was missing and I have amended the code.

Thank you for your reply, but is still have the same problem as before which I am not sure on how to amend
Now where in the SendMailCDO do you refer to the emailReportAsPDF Sub routine

How do I call the sub routine from SendMail CDO?
 

bastanu

AWF VIP
Local time
Today, 16:43
Joined
Apr 13, 2010
Messages
1,401
Now where in the SendMailCDO do you refer to the emailReportAsPDF Sub routine
I think you have all wrong, it is the other way around; look at the code and you will see that emailReportAsPDF first creates your email list (vRecipientList), then it exports the report to PDF:
Code:
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

Docmd.OutputTo acReport,"Email SB Notification - From TechPubs - All - SB TBL",acFormatPDF, vReportPDF

and finally calls the SendMailCDO providing all the required arguments:
Code:
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
SendEMailCDO vRecipientList,"",vSubject,vMsg,"",vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

So what you need to do is to simply use:
Code:
Call emailReportAsPDF 'you can even leave Call out

in the Click event of your "Email Report" command button.

Cheers,
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
I think you have all wrong, it is the other way around; look at the code and you will see that emailReportAsPDF first creates your email list (vRecipientList), then it exports the report to PDF:
Code:
'<<<<<<<<<<<<<<<<<<<<export the report as PDF>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

Docmd.OutputTo acReport,"Email SB Notification - From TechPubs - All - SB TBL",acFormatPDF, vReportPDF

and finally calls the SendMailCDO providing all the required arguments:
Code:
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
SendEMailCDO vRecipientList,"",vSubject,vMsg,"",vReportPDF
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

So what you need to do is to simply use:
Code:
Call emailReportAsPDF 'you can even leave Call out

in the Click event of your "Email Report" command button.

Cheers,
Oh, Now I get it, I hope :)

My OnClicked ran Submit where it checked for settings as plain txt or HTML and then from there it ran the SendMailCDO
I still had the Submit , SendMail and SendHTMLMail in the code
Private Sub Submit_Click()
On Error GoTo Err_btnEmail_Click

Select Case Me.cboEMailType

Case 1 'plain text
SendEMail

Case 2 'HTML
SendHTMLEMail

End Select

Exit_btnEmail_Click:
Exit Sub

Err_btnEmail_Click:
MsgBox Err.Description
Resume Exit_btnEmail_Click
End Sub




Sub SendEMail()

aTo = txtTo 'recipient address
aCC = CurrentUserMail
aFrom = TxtFrom 'sender address
aSubject = "New Document Loaded"
aPath = TXTFilename



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


aTo = txtTo 'recipient address
aCC = CurrentUserMail
aFrom = TxtFrom 'sender address
aPath = TXTFilename

Dim strImage As String, strSource As String
'inline image for HTML email
'strImage = " <P><IMG border=0 hspace=0 alt='' src='file://G:/Programs/MendipDataSystems/CommonFiles/SDA/Images/MDSBanner.png' align=baseline></P>"
'use forward slashes for file path and enclose in single quotes
strSource = "'file://" & Replace(CurrentDBDir(), "\", "/") & "MDSBanner.png'"
strImage = " <P><IMG border=0 hspace=0 alt='' src=" & strSource & " align=baseline></P>"

'check image exists in this folder
If Dir(CurrentDBDir & "MDSBanner.png") = "" Then
MsgBox "The sample image file 'MDSBanner.png' cannot be found" & vbCrLf & "This routine will now close"
Exit Sub
End If



SendHTMLEMailCDO aTo, aCC, aSubject, aHTMLBody, aFrom, aPath

End Sub

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

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

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 Sub
Sub emailReportAsPDF()
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

End Sub
 
Last edited:

bastanu

AWF VIP
Local time
Today, 16:43
Joined
Apr 13, 2010
Messages
1,401
Just move the Select Case (where you are checking for plain text or HTML to emailReportAsPDF replacing the line calling the SendEMailCDO
Code:
'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Select Case Me.cboEMailType

Case 1 'plain text
SendEMailCDO vRecipientList, "", vSubject, vMsg, "", vReportPDF

Case 2 'HTML
SendEMailHTMLCDO vRecipientList, "", vSubject, vMsg, "", vReportPDF 'you seem to be missing this sub
                                

End Select

'<<<<<<<<<<<<<<<<<<call Colin's sub to email report as attachment>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
Hi All,

I have searched all over and not sure on how to handle this.
Every user that needs to send email would require to enter his windows password as this is the requirement for Gsuig GMail authentication.
I managed to get the windows user name.
As security is priority, how can I use vba to lookup the windows password as we do with GetUserName, but not to store or make the password visible?
If not, do you have a work around for this one? I do not want the users to enter their windows password each time they need to send the email.
or, how would I be able to reference active directory?
 

isladogs

MVP / VIP
Local time
Today, 23:43
Joined
Jan 14, 2017
Messages
18,186
Not true (unless its changed in the last few weeks).
There are two solutions described on the final page of the Help file supplied with my CDO Email Tester app (see post #8)
This is the relevant part
1614086541066.png


I use the Set App Password approach. It works...or at least it did when last tested a couple of weeks ago
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
I have come to a point where I am happy with the code

Thank you all for the assistance and guidance. will take a few day to test

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

Private Sub emailReportAsPDF_Click()

'Enter Password
Dim Message, Title, Default, WPass
Message = "Enter Windows Password"
Title = "InputBox"
WPass = InputBox(Message, Title, Default)
TempVars = ["WPass"]


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

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

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 WPass As String

cboEmailType = EmailType
txtSendUsing = SendUsing
txtPort = ServerPort
txtServer = EmailServer
txtAuthenticate = SMTPAuthenticate
txtusername = GetUserName
txtPassword = WPass
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
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
Hi All,

Please advise on where the error is in my code

User must enter the password
then update the table WPass to control WPassEnt

Dim SQL As String
Dim WPassStr As String

'Enter Password
Dim Message, Title, Default
Message = "Enter Windows Password"
Title = "Enter Parameters"
WPassStr = InputBox(Message, Title, Default)


DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE WPass SET WPassEnt = WPassStr"
DoCmd.SetWarnings True
 

bastanu

AWF VIP
Local time
Today, 16:43
Joined
Apr 13, 2010
Messages
1,401
Try:
"UPDATE WPass SET WPassEnt ='" & WPassStr & "'" or better:
"UPDATE WPass SET WPassEnt =""" & WPassStr & """"
Cheers,
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
Try:
"UPDATE WPass SET WPassEnt ='" & WPassStr & "'" or better:
"UPDATE WPass SET WPassEnt =""" & WPassStr & """"
Cheers,
the table does not seem to update, it remains blank with no records
 

Gismo

Registered User.
Local time
Tomorrow, 01:43
Joined
Jun 12, 2017
Messages
1,298
the table does not seem to update, it remains blank with no records
Oh yes, please could you advise, I only want to request for an password in the Inputbox if the WPass tbl is blank
 

bastanu

AWF VIP
Local time
Today, 16:43
Joined
Apr 13, 2010
Messages
1,401
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,
 

Users who are viewing this thread

Top Bottom