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
Related
I've included the last line of data entered to my HTML body. However the column headers are not showing, what am I doing wrong?
Private Sub cmdEmail_Click()
'Declare Outlook Variables
Dim OLApp As Outlook.Application
Dim OLMail As Object
Dim MyData As Object
'Open the Outlook Application and Start a new mail
Set OLApp = New Outlook.Application
Set OLMail = OLApp.CreateItem(0)
Set MyData = ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13)
OLApp.Session.Logon
With OLMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Quality Alert"
.HTMLBody = "<P><font size='6' face='Calibri' color='black'>Quality Issue Found<br><br> Please reply back with what adjustments have been made to correct this issue. </font></P>" & ConvertRangeToHTMLTable(ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13))
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Database")
Dim wb As Workbook
ws.Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\Temp\Database.xlsx" 'Change Path
.Display
' .Send
wb.Close SaveChanges:=False
Kill "C:\Temp\Database.xlsx"
End With
'Clearing Memory
Set OLMail = Nothing
Set OLApp = Nothing
End Sub
Only the 1st 13 columns of the last row are being targeted.
ThisWorkbook.Worksheets("Database").Cells(Rows.count, 1).End(xlUp).Resize(, 13)
I order to include all the data, you'll have to extend the range from the first cell to the last row.
With ThisWorkbook.Worksheets("Database")
Set MyData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
End With
Breaking up the code into smaller bites will allow you to easily isolate and test your code.
Extracting the code that targets the data range into its own function (in a public module) allows use Application.Goto to visibly inspect the range.
Application.Goto EmailData
Private Sub cmdEmail_Click()
Dim HTMLBody As String
HTMLBody = EmailHTMLFirstAndLastRow
SendEmail HTMLBody
CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit
End Sub
Place this code in a public module:
Sub SendEmail(HTMLBody As String)
'Declare Outlook Variables
Dim OLApp As Outlook.Application
Dim OLMail As Object
Dim MyData As Object
'Open the Outlook Application and Start a new mail
Set OLApp = New Outlook.Application
Set OLMail = OLApp.CreateItem(0)
OLApp.Session.Logon
With OLMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Quality Alert"
.HTMLBody = "<P><font size='6' face='Calibri' color='black'>Quality Issue Found<br><br> Please reply back with what adjustments have been made to correct this issue. </font></P>" & HTMLBody
.Display
' .Send
End With
'Clearing Memory
Set OLMail = Nothing
Set OLApp = Nothing
End Sub
Function EmailHTMLFirstAndLastRow() As String
Dim Target As Range
Set Target = EmailData
With Target
.EntireRow.Hidden = msoTrue
.Rows(1).Hidden = msoFalse
.Rows(.Rows.Count).Hidden = msoFalse
.EntireRow.Hidden = msoFalse
End With
EmailHTMLFirstAndLastRow = RangetoHTML(Target.Rows(Target.Rows.Count))
End Function
Function EmailData() As Range
With ThisWorkbook.Worksheets("Database")
Set EmailData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Resize(, 13))
End With
End Function
Sub CreateACopyOfTheDatabaseSaveItCloseKillItButNeverDoAnythingWithit()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Database")
Dim wb As Workbook
ws.Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\Temp\Database.xlsx" 'Change Path
wb.Close SaveChanges:=False
Kill "C:\Temp\Database.xlsx"
End Sub
Edit
I edited the code to create html for only the header and last rows, as per the OP's request. Since RangetoHTML() ignores hidden rows, I define the range of data, hid all but the fist and last rows, the passed the range to RangetoHTML() and assigned its value to a variable, the unhid the range.
I'm trying to improve my knowledge of MS Access to benefit my companies operations. at the moment I'm trying to use information from a Form to populate an email. I've kept it basic to ensure I have the theory correct before adding further information.
I have a table called ClientListtbl and a Form called ClientListfrm.
I want a button to generate an email prepopulated with the Email Address (field named is EmailAddress) in the "TO" part of the email and the Last Name (field named LastName) in the subject. I will want to put a "Notes" field into the email body eventually but thought better to start small.
after trawling stackoverflow and other resources I came across a code that seemed to fit and retrofitted it to my database, the code is as follows:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Object
Dim objEmail As Object
LastName = ClientListfrm!LastName
Email = ClientListfrm!EmailAddress
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
EmailAddress is short text
LastName is Short text
when I then click the button I get an error stating
run-time error '424' Object required
clicking on debug LastName = ClientListfrm!LastName is highlighted. So i tried changing LastName and EmailAddress to As Object. which gives the same error.
any help much appreciated.
cheers
This - with a reference to Outlook - works for me:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
LastName = "Macron" 'ClientListfrm!LastName
Email = "someone#example.com" 'ClientListfrm!EmailAddress
Set objOutlook = Outlook.Application
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
So, what's missing is probably the syntax for the form controls:
LastName = Forms!ClientListfrm!LastName.Value
Email = Forms!ClientListfrm!EmailAddress.Value
Simply a syntax error in the way you are trying to call the field in the form. This worked for me, but there may be other methods:
Private Sub Command20_Click()
Dim LastName As Variant
Dim Email As Variant
Dim objOutlook As Object
Dim objEmail As Object
LastName = Forms("ClientListfrm").LastName
Email = Forms("ClientListfrm").EmailAddress
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
With objEmail
.To = Email
.Subject = LastName
.send
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
I am trying to send a fax from Outlook using a different Outlook address than mine which is the one that it defaults to. Below is my code.
Thank you.
Private Sub FaxDoctor() ' Faxes the doctor with the letter
On Error GoTo Error_Handler
Dim fso
Dim olApp As Object
' Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists("\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf") Then ' If the filename is found
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olfolder = olNS.GetDefaultFolder(olFolderInbox)
Set olMailItem = olfolder.Items.Add("IPM.Note")
olMailItem.display
With olMailItem
.Subject = " "
.To = "[fax:" & "Dr. " & Me.[Prescriber First Name] & " " & Me.[Prescriber Last Name] & "#" & 1 & Me!Fax & "]" ' Must be formatted exactly to be sent as a fax
'.Body = "This is the body text for the fax cover page" ' Inserts the body text
.Attachments.Add "\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf" ' attaches the letter to the e-mail/fax
'.SendUsingAccount = olNS.Accounts.Item(2) 'Try this to change email accounts
End With
Set olMailItem = Nothing
Set olfolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Else
GoTo Error_Handler
End If
Exit_Procedure:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox ("No Letter found" & vbCrLf & "If you are certain the letter is saved with the correct filename then close down Outlook and try again.") ' This often crashes because the letter is not found or because outlook has crashed. In which case every Outlook process should be closed and Outlook should be restarted.
Exit Sub
End Sub
You can change the outlook account by using the 'SendUsingAccount' property of the mail item. This needs to be set to an account object.
You can set the account for a given name using something like this where 'AccountName' is the address you're sending from.
Dim olAcc as Outlook.Account
For Each olAcc In Outlook.Session.Accounts
If outAcc.UserName = 'AccountName' Then
olMailItem.SendUsingAccount = outAcc
Exit For
End If
Next
Try using ".SendOnBehalfOfName"
I found this function online, so just follow its lead:
Function SendEmail()
Dim Application As Outlook.Application
Dim NameSpace As Outlook.NameSpace
Dim SafeItem, oItem ' Redemption
Set Application = CreateObject("Outlook.Application")
Set NameSpace = Application.GetNamespace("MAPI")
NameSpace.Logon
Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "customer#ispprovider.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.SendOnBehalfOfName = "Invoices#companyname.com"
SafeItem.Send
End Function
I am writing an Access 2007 application that sends an email and selects the body of the email based on a variable. I have each of the optional emails stored in a table. My current code looks like this:
Dim MyMail As Outlook.MailItem
Dim WhatEmail As Integer
Set WhatEmail = 3
MyMail.Body = "SELECT [Emails].[Body] FROM [Emails] WHERE EmailNumber = WhatEmail"
My Emails table has columns EmailNumber (integer) and Body.
I am receiving a Compile error:
Expected: line number or label or statement or end of statement.
Your code as it is will not be doing anything meaningful; your "SELECT... " statement is merely a string, and (if the code did actually work), it would set the message body to exactly that: "SELECT [Emails].[Body] ...".
Presumably not what you want at all!
Instead we must use DAO (or similar) to get the message body from our database.
Public Sub sendMail()
Dim WhatEmail As Integer
Dim strSQL As String, strMessageBody As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim oApp As Outlook.Application
Dim oMail As MailItem
WhatEmail = 2
strSQL = "SELECT [Body] FROM [Emails] WHERE EmailNumber = " & WhatEmail
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
If (rs.EOF And rs.BOF) Then
Debug.Print "No matching email found"
Exit Sub
End If
rs.MoveFirst
strMessageBody = rs![Body]
rs.Close
Set rs = Nothing
Set db = Nothing
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = strMessageBody
oMail.Subject = "subject of email"
oMail.To = "name#domain.com"
oMail.Send
Set oMail = Nothing
Set oApp = Nothing
End Sub
Notes on changes from your original:
The variable WhatEmail is now outside the quotes of the string, so VBA uses the value of the variable rather than the text "WhatEmail". This means we set strSQL to
"SELECT [Body] FROM [Email] WHERE EmailNumber = 2"
(or whatever number you have set your WhatEmail variable as), rather than
"SELECT [Body] FROM [Email] WHERE EmailNumber = WhatEmail"
We then load a recordset using DAO with this SQL string as the parameter. It will hopefully return just one record (the correct line from our Emails table) - but if something has gone wrong and there is no matching EmailNumber in the table, we will get a message in the Immediate window ("No matching email found") and the procedure will exit.
Otherwise, we look at the record in the table (rs.MoveFirst) and then get the Body field of it with rs![Body].
Note: I have assumed that there will be at most one entry in the Emails table with a matching EmailNumber - in my database it is the primary key.
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