Getting Access to send emails to dynamic addresses - ms-access

This is in Access 2010 and I have virtually no experience or familiarity with VBA.
In my form (frmEmailLookup), I have combo boxes and list boxes and a subform set up so that when the user selects a building from cmbBuilding the remainder of the form populates with the data on that building, including the contact emails for up to 4 people in the building (lstBuildingRepEmail1, lstBuildingRepEmail2, lstBuildingRepEmail3, lstBuildingRepEmail4). I need a button (butEmailRecords) to generate an email with the query from the subform (qryBuildingAreaLookup) as an attachment. I can set up a macro that will something close, but it doesn't allow for dynamic email addresses. I don't want my users to have to go that far into the program to make updates.
Any help is appreciated and I know I'm asking for a lot of code writing help.
Here's what I've tried:
Option Compare Database
Private Sub butEmailRecords_Click()
Dim outputFileName As String
outputFileName = CurrentProject.Path & "\BuildingInventory" & ".xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryBuildingAreaLookup", outputFileName, True
On Error GoTo Error_Handler
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("qryBuildinAreaLookup")
With rs
With objEmail
.To = tblBuilding.BuildingRep1
.To = tblBuilding.BuildingRep2
.To = tblBuilding.BuildingRep3
.To = tblBuilding.BuildingRep4
.Subject = "Look at this sample attachment"
.body = "The body doesn't matter, just the attachment"
.Attachments.Add "L:\Administration\FacilityInventoryDatabase\BuildingInventory.xls x"
.Send
'.ReadReceiptRequested
End With
Exit_Here:
Set objOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox Err & ": " & Err.Description
Resume Exit_Here
End Sub

Here is the basics of what I use:
'Refers to Outlook's Application object
Dim appOutlook As Object
'Refers to an Outlook email message
Dim appOutlookMsg As Object
'Refers to an Outlook email recipient
Dim appOutlookRec As Object
'Create an Outlook session in the background
Set appOutlook = CreateObject("Outlook.Application")
'Create a new empty email message
Set appOutlookMsg = appOutlook.CreateItem(olMailItem)
'Using the new, empty message...
With appOutlookMsg
'SQL statement to grab emails
Set recordset = currentdb.openrecordset('SQL statement')
Do While Not recorset.EOF
Set appOutlookRec = .Recipients.Add(recordset.Email)
appOutlookRec.Type = olTo
recordset.MoveNext
Loop
.Subject = ....
.Body = ....
.Send
End With
and that's the basics of what I use. I'm a beginner so this may not be the best way, but it should be a start. (I also had to add Microsoft Oulook in the reference library.)

I use CDO objects to send messages because I prefer not to rely on Outlook (for anything).
There is quite a comprehensive article on using CDO to send mail (including downloadable VBA code) here:
http://www.cpearson.com/excel/Email.aspx

Related

Sending Outlook HTML email using Excel VBA generates runtime error

I'm trying to send a message from Excel. It triggers a run time error when I get to .HTMLBody.
Sub CreateHTMLMail()
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
With xMailOut
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><H2>The body of this message will appear in HTML.</H2><BODY>Type the message text here. </BODY></HTML>"
.Display
End With
End Sub

Access Send Email with Attachment [duplicate]

I have some code that creates a Mail object (Outlook), attaches a file and sends it.
Dim mobjOutlook, mobjActiveExp, mobjNewMail As Object
'Create Outlook objects
Set mobjOutlook = CreateObject("Outlook.Application")
Set mobjActiveExp = mobjOutlook.ActiveExplorer
Set mobjNewMail = mobjOutlook.CreateItem(olMailItem)
'Setup and send email
With mobjNewMail
.To = "someone#test.com"
.Subject = "theSubject"
.Body = "some text"
.Attachments.Add "C:/The/File/Path.doc"
'*I need to check here if the above line worked*
.Send
End With
How can I test if the attachment works before sending? Is this possible? For some reason even if it doesn't, it still sends the email without the attachment.
I was thinking of somehow utilizing the '.Save' option.
Any thoughts or suggestions are much appreciated,
thanks.
You could just test the number of attachments in the email were > 0
Also
Dim mobjOutlook, mobjActiveExp, mobjNewMail As Object
will dim the first two variables as variants, so I have recut this below
Sub Test()
Dim mobjOutlook As Object
Dim mobjActiveExp As Object
Dim mobjNewMail As Object
'Create Outlook objects
Set mobjOutlook = CreateObject("Outlook.Application")
Set mobjActiveExp = mobjOutlook.ActiveExplorer
Set mobjNewMail = mobjOutlook.CreateItem(olMailItem)
'Setup and send email
With mobjNewMail
.To = "someone#test.com"
.Subject = "theSubject"
.Body = "some text"
.attachments.Add "C:\temp\step1.png"
If .attachments.Count > 0 Then
.Send
Else
MsgBox "No attachment", vbCritical
End If
End With
End Sub

Access 2016 processing duplicate mail to Outlook via VBA

I have an Access 2016 database with tables that hold student data. I have managed to successfully send an email to each recipient using VBA-Outlook (the code works), however, it looks to have sent the the email to the same recipients multiple times (random duplicate of 1 to 4 emails per recipient).
I can confirm that there are no duplicate [E-mail Address] whatsoever contained within the Student table.
When I use .Display instead of .Send in my oEmailItem, there does not appear to be any duplicates. Perhaps I should include a waiting period of 1 second in the loop?
On Error Resume Next is used to bypass the null value returned by blank email fields; not everyone has an [E-mail Address] in this table
Why is this code sending random duplicate email to recipients?
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub
Update:
Thanks HiPierr0t. Your answer showed me that I wasn't emptying the variable at the end of the loop; thus assigning the previously used [E-mail Address] when met with a null or blank email field.
I did have to keep
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
inside the loop however (strange, must be a MS thing).
I ended up removing On Error Resume Next as it does create more problems, and used
myemail = Nz(rS![Email Address], vbNullString)
to change any null or blank fields into "". That way, I don't need to empty to variable each time as the lookup changes it to "" if it's null anyway. The If..Else takes care of the rest.
Do While Not rS.EOF
'On Error Resume Next
myemail = Nz(rS![Email Address], vbNullString)
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
If myemail = "" Then
rS.MoveNext
Else
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Display
End With
'End of my emailing report
rS.MoveNext
End If
Loop
On Error Resume Next tends to create more problems than it solves.
If no email exists, your code goes on. However your variable myemail is still filled with the previous email you sent an email to.
1- Make sure to empty your variable after the email is sent with myemail = "" or myemail = vbNullString.
2- Before sending the email, check that myemail is not empty with an If statement.
3- You may want to place your code below outside of the loop. It won't make a big difference but there is no need to process this part of code every time.
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
Please check if you’ve emptied the myemail before sending e-mail.
Also you need to add “rS.Close dbS.Close” after the Loop.
Here is complete code:
Private Sub SendEmail_Click()
Dim rS As DAO.Recordset
Dim dbS As DAO.Database
Dim Filepath As String
Dim Folderpath As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim myemail As String
Dim Subjectline As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We need a Subject Line!")
Set dbS = CurrentDb()
Set rS = dbS.OpenRecordset("SELECT * FROM Students")
Do While Not rS.EOF
On Error Resume Next
myemail = ""
myemail = rS![E-mail Address]
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
'Set the email template
Set oEmailItem = oOutlook.CreateItemFromTemplate("C:\MailTemplate\Mail1.oft")
With oEmailItem
.To = [myemail]
.Subject = Subjectline$
.Send
End With
'End of emailing
rS.MoveNext
Loop
rS.Close
dbS.Close
Set oEmailItem = Nothing
Set oOutlook = Nothing
Set rS = Nothing
Set dbS = Nothing
End Sub

Access 2013 - Send an email automatically with outlook and Windows Task Scheduler

I have an access macro that runs a set of Netezza queries and uploads the results to a database. It then opens and refreshes an Excel file that utilizes this data and saves the file in a couple of locations. Finally it composes an automated email and sends it to a distribution list. When I manually run the macro, everything works 100% perfectly.
In order to make my life a bit easier, I am using Windows Task Scheduler (Windows 10) to automatically fire the macro once a day, and this is where my issue lies. Task Scheduler fires the macro off without a hitch, all of the queries refresh, the excel files are saved, but the e-mail is not sent.
Here is the code SendOutlookEmail code that I'm using
Sub sendOutlookEmail()
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim SpDate As String
Dim Signature As String
Dim StrPath As String
Dim StrFilter As String
Dim StrFile As String
SpDate = Format(Now() - 1, "yyyy-mm-dd")
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.Display
End With
Signature = oMail.HTMLBody
With oMail
.SentOnBehalfOfName = "My Email"
.To = "CCO Reporting"
.Subject = "AHT - ACW Dashboard - " & SpDate
.HTMLBody = "<span LANG=EN>" _
& "<font FACE=SegoeUI SIZE = 3>" _
& "The IB/OB AHT - ACW reports have been updated and placed in the following folder:" _
& "<br><br>" _
& "<a href='File Location'>File Location</a>" & "<br><br><br></font></span>" _
& Signature
'.Attachments.Add (StrPath & StrFile)
'.Display
.Send
End With
On Error GoTo 0
Set oMail = Nothing
Set oApp = Nothing
End Sub
Here is the task scheduler settings
Task Scheduler
Possibly Outlook just doesn't have enough time to send the message, as it instantly gets closed after the message is moved to the outbox (.send doesn't send the message as far as I know, but just moves it to the outbox and triggers a send for all items in there).
Try to manually add a send/receive, to make Access wait for Outlook to actually send the mails (add this to your vba before the Set oApp = Nothing):
' Synchronizes (ie sends/receives) OL folders.
' Ref: http://msdn.microsoft.com/en-us/library/ff863925.aspx
Dim objNsp As Outlook.NameSpace
Dim colSyc As Outlook.SyncObjects
Dim objSyc As Outlook.SyncObject
Dim i As Integer
On Error GoTo SyncOL_Err
Set objNsp = oApp.Application.GetNamespace("MAPI")
Set colSyc = objNsp.SyncObjects
For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
Debug.Print objSyc.Name
objSyc.start
Next
Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing

Disable outlook security settings using VBA

I am trying to auto email a report from access using VBA in a macro. The report is sent from Access2007 by outlook2007. When the report is being sent, I get a security message from outlook saying "a program is trying to access your Address book or Contacts" or "a program is trying to access e-mail addresses you have stored in Outlook..." . This message is a problematic for me because I want to use windows task scheduler to automatically send the report without any human interaction.So I want to disable this security notification. I searched on Google and here is the code I have so far but giving me errors and I am not sure what else I should do. Thanks for your help in advance. I am a beginner programmer. The error is
Public Sub Send_Report()
Dim strRecipient As String
Dim strSubject As String
Dim strMessageBody As String
Dim outlookapp As Outlook.Application
Set outlookapp = CreateObject("Outlook.Application")
OlSecurityManager.ConnectTo outlookapp 'error is here says object required
OlSecurityManager.DisableOOMWarnings = True
On Error GoTo Finally
strRecipient = "example#yahoo.com"
strSubject = "Tile of report"
strMessageBody = "Here is the message."
DoCmd.SendObject acSendReport, "Report_Name", acFormatPDF, strRecipient, , , strSubject, strMessageBody, False
Finally:
OlSecurityManager.DisableOOMWarnings = False
End Sub
You get the error because OlSecurityManager is nothing. You haven't declared it, you haven't set it to anything, so when you attempt to use it, VBA has no idea what you're talking about!
It looks like you're trying to use Outlook Security Manager, which is an add-in sold here. Have you purchased it? Because if not, then you probably don't have it on your system.
If you do have it, then you probably need to declare and set it like this:
Dim OlSecurityManager As AddinExpress.Outlook.SecurityManager
Set OlSecurityManager = New AddinExpress.Outlook.SecurityManager
If you, as I suspect, don't have it, then an alternative is sending e-mail using CDO. Here's an example:
First, set a reference to the CDO library in Tools > References > checkmark next to Microsoft CDO for Windows Library or something like that.
Dim cdoConfig
Dim msgOne
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServerPort) = 25 'your port number, usually is 25
.Item(cdoSMTPServer) = "yourSMTPserver.com"
'.Item(cdoSendUserName) = "your username if required"
'.Item(cdoSendPassword) = "your password if required"
.Update
End With
Set msgOne = CreateObject("CDO.Message")
With msgOne
Set .Configuration = cdoConfig
.To = "recipient#somehwere.com"
.from = "you#here.com"
.subject = "Testing CDO"
.TextBody = "It works just fine."
.Attachments.Add "C:\myfile.pdf"
.Send
End With
This is a bit more annoying than Outlook, because you need to know in advance the address of the SMTP server to be used.
I know this is a late answer, but I just ran into a similar problem. There is another solution using Outlook.Application!
I stumble upon it while looking for the solution, full credit here:
http://www.tek-tips.com/faqs.cfm?fid=4334
But what this site's solution simply suggest, instead of using the .send command, use the `.Display" command and then send some keys from the keyboard to send the email, like below:
Sub Mail_workbook_Outlook()
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "Someone#Somewhere.com"
.CC = ""
.BCC = ""
.Subject = "This is an automated email!"
.Body = "Howdy there! Here, have an automated mail!"
.Attachments.Add ActiveWorkbook.FullName
.Display 'Display instead of .send
SendKeys "%{s}", True 'send the email without prompts
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End
End Sub