VBA Cancel send email sent by Gmail - ms-access

I know that Google Gmail was a functionality to cancel the sent email within 30 seconds.
As I'm using this code to send emails from an access database, and via gmail, I would like to know if there's a way to use that functionality to prevent sending an email for mistake?
Sub SendEmail_Click()
Dim NewMail As CDO.Message
Set NewMail = New CDO.Message
'Enable SSL Authentication
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
'Make SMTP authentication Enabled=true (1)
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'Set the SMTP server and port Details
'To get these details you can get on Settings Page of your Gmail Account
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Set your credentials of your Gmail Account
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mysite#gmail.com"
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mypassword7"
'Update the configuration fields
NewMail.Configuration.Fields.Update
'Set All Email Properties
With NewMail
Dim strPath As String
strPath = ".mysite/wp-content/uploads/2017/07/myimage.png"
.subject = "this is the subject"
.From = "<mail#mysite.com>"
.To = Me.EMAIL
'.CC = ""
'.BCC = ""
.HTMLBody = "This is my message body"
.AddAttachment "https://mysite/temp/contacts.vcf"
End With
NewMail.Send
MsgBox ("This email was sent!")
'Set the NewMail Variable to Nothing
Set NewMail = Nothing
End Sub

Related

Password recovery asp

i am requesting a problem about forgot password .
if user forgot his/her password how can i return his/her same password in email address? My problem would be the SQL database password is encrypted how am I suppose to retrieve the same password instead encrypted.
i did like this:
<!--
METADATA
TYPE="typelib"
UUID="CD000000-8B95-11D1-82DB-00C04FB1625D"
NAME="CDO for Windows 2000 Library"
-->
<%
DIM strEmail
strEmail = Request.Form("email")
IF strEmail <> "" THEN
%>
<%
DIM objDB, rs, rssql
Set objDB = Server.CreateObject("ADODB.Connection")
objDB.Open "Provider=MSDASQL.1;Password=langas;Persist Security Info=True;User ID=mmsg;Data Source=mmsg_web"
rssql = "SELECT email_addr, medacist_password FROM medacist_user WHERE email_addr = '" & strEmail & "'"
Set rs = objDB.Execute(rssql)
IF rs.EOF THEN
Response.Write "That email address was not found in our database. Please click Back on your browser and enter the email address you registered with."
ELSE
DIM strPassword
set strPassword = rs("medacist_password")
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "10.1.1.186" 'Ongoing sever SMTP required \\'
'' .Item(cdoSMTPAuthenticate) = 1'
'' .Item(cdoSendUsername) ="<enter_username>"
' ' .Item(cdoSendPassword) ="<enter_password>"''
.Update
End With
Set cdoMessage = CreateObject("CDO.Message")
With cdoMessage
Set .Configuration = cdoConfig
.From = "clu#medacist.com"
.To = strEmail
.Subject = "Forgotten Password"
.HTMLBody = "Here is your password: " & strPassword
.Importance = 1
.Send
End With
Set cdoMessage = Nothing
Set cdoConfig = Nothing
Response.Write "Your password has been sent to your email address."
END IF
ELSE
Response.Write "Please click Back on your browser and enter the email address you registered with."
END IF
%>
<!-- "Please click below link to reset your password: <br> <a href='https://www.medacist.com/login/test_globals.asp'>Click this link to reset your password</a>" -->
You aren't supposed to retrieve the password.
You should generate a long, pesudo-random token. Store it for a short time (e.g. 24 hours). Send it to the user (normally embedded in a URL). When the user follows the link in the email, they should get a page allowing them to set a new password (and you can use the token in the URL to identify which user's password is being changed).

Insert Dynamic Table into email

The below script generates a text list and inserts it into an email and sends to specific people. It works fine as plain text. What I am trying to accomplish is to create a dynamic html table and insert into the body of the email. I have tried to add html tags around the TextBody for the .HTMLBody property, but no email came out. I changed the template files to .html files and created html tables in there, but the email had the code as plain text.
Here is a sample of the working output:
AREA: Line 2
SPID: 308582 Name: LINE 2 ROBERTS NO 2 COOLING LINE East
Expectation: BiMonthly
Projected: +2mos Last Sampled Approved Date: 2013-06-10
I would like to have all the text before the colons to be the headers and then the results listed below the headers.
Option Explicit
Dim mConnectionString, objFSO, vEmailTemplateFile, vEmailTemplateSPID
Dim blnDebugMode, DebugLogLevel
Dim oConn 'ADO connection
Dim vLogDir,LogFilePrefix,gstrmsg
Dim adminEmail, EmailSubject, smtpServer
mConnectionString = "Provider=SQLOLEDB;Server=;Initial Catalog;Integrated Security=;"
vEmailTemplateFile = "C:\EMAILScripts\SampleReminderTemplate.txt"
vEmailTemplateSPID = "C:\EMAILScripts\SampleReminderSPIDTemplate.txt"
'Read in SPID template
sSPIDTemplate = ""
Set objFileStreamIn = objFSO.OpenTextFile(vEmailTemplateSPID, ForReading)
Do Until objFileStreamIn.AtEndOfStream
sSPIDTemplate = sSPIDTemplate & objFileStreamIn.ReadLine & vbCrLf
Loop
objFileStreamIn.Close
'Read in email template and create email by replacing tokens and then send
sEmailMsg = ""
Set objFileStreamIn = objFSO.OpenTextFile(vEmailTemplateFile, ForReading)
Do Until objFileStreamIn.AtEndOfStream
sEmailMsg = sEmailMsg & objFileStreamIn.ReadLine & vbCrLf
Loop
objFileStreamIn.Close
sEmailMsg = Replace(sEmailMsg,"{name}",sName)
sEmailMsg = Replace(sEmailMsg,"{body}",sBody)
'LogMessage "sEmailMsg: " & sEmailMsg, False, LogDebug
If blnDebugMode Then
sEmail = adminEmail '<< In debug mode send ALL emails to the admin address set above
End If
If blnEmail Then
If SendMailByCDO(adminEmail, EmailSubject, FullErrorMsg, "", "", smtpServer, adminEmail) <> 0 Then
LogMessage "Could Not send email: " & ErrMsg, False, LogError
If errNumber <> Err.Number Then
Err.Clear
End If
End If
End If
'***************************************
'* Sends an email To aTo email address, with Subject And TextBody.
'* The email is In text format.
'* Lets you specify BCC adresses, Attachments, smtp server And Sender email address
'***************************************
Function SendMailByCDO(aTo, Subject, TextBody, BCC, Files, smtp, aFrom )
'On Error Resume Next
Dim Message 'As New CDO.Message '(New - For VBA)
Set Message = CreateObject("CDO.Message")
With Message.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendemailaddress") = aFrom
'SMTP settings - without authentication, using standard port 25 on host smtp
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtp
'SMTP Authentication
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoAnonymous
'**** You can also specify authentication properties for the smtp session using
'**** smtpauthenticate and sendusername + sendpassword:
'* .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
'* .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "info#mycompany.to"
'* .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
'* .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True/False
'****
.Update
End With
'Set other message fields.
With Message
.From = aFrom
.To = aTo
.Subject = Subject
'Set TextBody property If you want To send the email As plain text
'.TextBody = TextBody
'* Set HTMLBody property If you want To send the email As an HTML formatted
.HTMLBody = TextBody
'Blind copy And attachments are optional.
If Len(BCC)>0 Then .BCC = BCC
If Len(Files)>0 Then .AddAttachment Files
'Send the email
.Send
End With
IF blnDebugMode and Err.Number <> 0 then
Wscript.Echo "SendMailByCDO err: " & err.description
End IF
'Returns zero If successful. Error code otherwise
SendMailByCDO = Err.Number
End Function
EDIT1: removed extra code to only show email functions.
I created an html file called SampleReminderSPIDTemplateTable.html to replace SampleReminderSPIDTemplate.txt and in that file is the following:
<html xmlns="http://www.w3.org/1999/xhtml">
<table style="width:100%">
<tr>
<td>{AREANAME}</td>
<td>{SPID}</td>
<td>{SPIDNAME}</td>
<td>{LASTSAMPLEAPPROVEDDATE}</td>
<td>{EXPECTATION}</td>
<td>{PROJECTED}</td>
</tr>
</table>
</html>
I also try this to .HTMLBody property, but no emails went out.
.HTMLBody = "<html><body><pre>" & TextBody & "</pre></body></html>"

Access 2007 Multiple Recipient Email

Currently I have this code for sending an email based on criteria from another form. The department I'm building this for has specified more than one person may receive the email. How do i get Access to look at a query that i have built. Which looks at the user table checks to see who can receive these emails and email the the list of emails from the query?
Select Case Forms!FRM_CallDetails!Model.Value
Case "SM", "TW", "LM", "LV", "SV"
On Error Resume Next
DoCmd.OutputTo acOutputForm, "FRM_CallDetails", acFormatXLS, "C:\temp\WatchList.xls", False
'Get Outlook if it's running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn 't running, start it from code
Set oApp = CreateObject("Outlook.Application")
Started = True
End If
Set oItem = oApp.CreateItem(olMailItem)
With oItem
.To = "google#google"
.Subject = "AutoEmail"
.Body = " this is the body of the email... this is a test email "
.Attachments.Add "C:\temp\WatchList.xls"
'Send the email
.Send
End With
Set oItem = Nothing
If Started Then
oApp.Quit
End If
'Display message to the user
MsgBox "A model that is on the watch list has been selected. An Automatic Email has been sent.", vbOKOnly
'Message Body Here
Case Else
'no email
End Select
Here is the SQL for the query i'm using which I have called Mail_List
SELECT TBL_Users.Email_Address
FROM TBL_Users
WHERE (((TBL_Users.EW_Email)="Y"));
you could replace your With block with the following:
With oItem
s = " SELECT TBL_Users.Email_Address" & _
" FROM TBL_Users " & _
" WHERE (((TBL_Users.EW_Email)='Y'));"
Set rs = CurrentDb.OpenRecordset(s)
listOfMails = ""
While Not rs.EOF
listOfMails = listOfMails & rs(0) & ";"
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
.To = listOfMails
.Subject = "AutoEmail"
.Body = " this is the body of the email... this is a test email "
.Attachments.Add "C:\temp\WatchList.xls"
'Send the email
.Send
End With
Add a declaration for the three variables used as well :
Dim rs As Recordset
Dim s As String, listOfMails as String
This does not actually use your premade query but rather generates it on the spot, but it gets the trick done.

Send HTML-formatted email messages from Access

Is there any way to send a mail in HTML format (and if possible with attachments) when your default mail client isn't Outlook?
Many thanks for any solution.
You should be able to use CDO (Collaboration Data Objects). The code will look something like this:
Option Compare Database
Option Explicit
Sub cdoHtmlTest()
Const urlPrefix = "http://schemas.microsoft.com/cdo/configuration/"
Dim msg As Object ' CDO.Message
Set msg = CreateObject("CDO.Message") ' New CDO.Message
With msg.Configuration.Fields
.Item(urlPrefix & "sendusing") = 2 ' cdoSendUsingPort
.Item(urlPrefix & "smtpserver") = "smtp.example.com"
.Item(urlPrefix & "smtpserverport") = 25
.Item(urlPrefix & "smtpauthenticate") = 1 ' cdoBasic
.Item(urlPrefix & "sendusername") = "mySmtpUserName"
.Item(urlPrefix & "sendpassword") = "mySmtpPassword"
.Item(urlPrefix & "smtpusessl") = False
.Update ' remember to do this step!
End With
With msg
.To = "gord#example.com"
.From = "gord#example.com"
.Subject = "HTML message test"
.HTMLBody = "This is a <strong>TEST</strong>."
.Send
End With
Set msg = Nothing
End Sub
For more examples (including how to send attachments), look here.

Sending an Email from MS Access No third party dll allowed

I need to send a series of email notifications from an MS Access Database.
No third party dll's like Redemption
Cannot trip the outlook security warnings
The email will have a pdf attachment
I know to do this I need to use MAPI, but I can't seem to find a way to do this with VBA.
Any help would be appreciated
Thanks,
Scott
If you can live with requiring CDO to be present on the machine, and you don't mind a user-provided SMTP server, you can use that. Just google for some example code, but for you convenience I'll paste some below from www.rondebruin.nl :
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
' = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
Set .Configuration = iConf
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub
Adding an attachment would be done using .AddAttachment "C:\files\filename.pdf" on the iMsg.
If the user has outlook installed:
Dim strErrMsg As String 'For Error Handling
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim oleGrf As Object
Dim strFileName As String
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
Set oleGrf = Me.OLEchart.Object
strFileName = "c:\temp\Graph.jpg"
oleGrf.Export FileName:=strFileName
With olMail
.To = "someone#somewhere.com"
.Subject = "Graph Info " & Format(Now(), "dd mmm yyyy hh:mm")
.Attachments.Add strFileName
.ReadReceiptRequested = False
.Send
End With
Kill strFileName
Also check out Tony Toews's Microsoft Access Email FAQ
See the page Microsoft Access Email FAQ - Directly via the Winsock I haven't tried those myself but you should be able to adapt the VB6 code to send the emails directly.